关于ACCESS数据导出到EXCEL

Henry D. Sy

给你一个导出查询到指定的excel（具体到工作表，开始行列）
excel请放在与本库同目录下

1. '---------------------------------------------------------------------------------------
   
2. ' Procedure : QueryToExcel
   
3. ' DateTime  : 2008-12-2 00:02
   
4. ' Author    : Henry D. Sy
   
5. ' Purpose   :
   
6. ' 参数      ;strQueryName  查询名
   
7. '            xlsName       Excel 文件名
   
8. '            strShtName    工作表名
   
9. '            Hval;Lval     分别为要导入的开始行和列
   
10. '---------------------------------------------------------------------------------------
    
11. '
    
12. Sub QueryToExcel(ByVal strQueryName As String, ByVal xlsName As String, ByVal _
    
13.                 strShtName As String, ByVal Hval As Integer, ByVal Lval As Integer)
    
14. ' Send the Query results to Excel
    
15. ' for further analysis
    
16.     Dim rs As ADODB.Recordset
    
17.     Dim objXL As Excel.Application
    
18.     Dim objWs As Excel.Workbook
    
19.     Dim fld As ADODB.Field
    
20.     Dim intCol As Integer
    
21.     Dim intRow As Integer
    
22. 
    
23.     Set rs = New ADODB.Recordset
    
24.     ' Get the desired data into a recordset
    
25.     rs.Open strQueryName, CurrentProject.Connection
    
26.     ' Launch Excel
    
27.     Set objXL = New Excel.Application
    
28.     ' Open a  worksheet
    
29.     Set objWs = objXL.Workbooks.Open(CurrentProject.Path & "" & xlsName & _
    
30.                                      ".xls")
    
31.     objWs.Worksheets(strShtName).Activate
    
32.     ' Copy the data
    
33.     ' First the field names　第一行是ACCESS中的列表名
    
34. 
    
35.     For intCol = 0 To rs.Fields.Count - 1  '是获取表中的列数
    
36.         Set fld = rs.Fields(intCol)
    
37.         objWs.Worksheets(strShtName).Cells(Hval, intCol + Lval) = fld.Name  'Excel中（1，1）开始输入列名
    
38.     Next intCol
    
39.     ' Now the actual data　现在开始复制数据
    
40.     intRow = Hval + 1      '你可以修改intRow从第几行开始输入数据，本例中是从第2行开始复制数据
    
41.     Do Until rs.EOF       '你可以修改intCol + 1从第几列开始输入数据，本例中是从第2行第1列开始复制数据
    
42.         For intCol = 0 To rs.Fields.Count - 1
    
43.             objWs.Worksheets(strShtName).Cells(intRow, intCol + Lval) = _
    
44.             rs.Fields(intCol).Value
    
45.         Next intCol
    
46.         rs.MoveNext
    
47.         intRow = intRow + 1
    
48.     Loop
    
49.     ' Make the worksheet visible
    
50.     objXL.Visible = True    '打开Excel表查看数据
    
51.     rs.Close
    
52.     Set rs = Nothing
    
53. 
    
54. End Sub

复制代码