导出access查询（表）到指定excel工作表

Henry D. Sy

1. '---------------------------------------------------------------------------------------
   
2. ' Procedure : QueryToExcel
   
3. ' DateTime  : 2008-12-2 00:02
   
4. ' Author      : Henry D. Sy
   
5. ' Purpose    : strQueryName 查询名（表名）
   
6. '                   xlsName 工作簿名
   
7. '                   strShtName 工作表名
   
8. '                   需要引用Microsoft Excel 11.0 Object Library
   
9. '---------------------------------------------------------------------------------------
   
10. '
    
11. Sub QueryToExcel(ByVal strQueryName As String, ByVal xlsName As String, ByVal _
    
12.                                                                         strShtName As String)
    
13. ' Send the Query results to Excel
    
14. ' for further analysis
    
15. 
    
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. 
    
25.     ' Get the desired data into a recordset
    
26.     rs.Open strQueryName, CurrentProject.Connection
    
27. 
    
28.     ' Launch Excel
    
29.     Set objXL = New Excel.Application
    
30.     ' Open a  worksheet
    
31.     Set objWs = objXL.Workbooks.Open(CurrentProject.Path & "" & xlsName & _
    
32.                                      ".xls")
    
33.     objWs.Worksheets(strShtName).Activate
    
34. 
    
35.     ' Copy the data
    
36.     ' First the field names
    
37.     For intCol = 0 To rs.Fields.Count - 1
    
38.         Set fld = rs.Fields(intCol)
    
39.         objWs.Worksheets(strShtName).Cells(1, intCol + 1) = fld.Name
    
40.     Next intCol
    
41.     ' Now the actual data
    
42.     intRow = 2
    
43.     Do Until rs.EOF
    
44.         For intCol = 0 To rs.Fields.Count - 1
    
45.             objWs.Worksheets(strShtName).Cells(intRow, intCol + 1) = _
    
46.             rs.Fields(intCol).Value
    
47.         Next intCol
    
48.         rs.MoveNext
    
49.         intRow = intRow + 1
    
50.     Loop
    
51. 
    
52.     ' Make the worksheet visible
    
53.     objXL.Visible = True
    
54.     rs.Close
    
55.     Set rs = Nothing
    
56. End Sub

复制代码

1. Private Sub Command0_Click()
   
2.     QueryToExcel "要导出的查询（表）名", "工作簿名", "工作表名"
   
3. End Sub

复制代码

简

哎，不错不错，简化成函数了，以往我都是引用红尘版主那个导出excel的例子，你的比红尘版主的要简单些，红尘版主对错误的处理要全面些。

Benjamin_luk

数据量大的话，建议用数组的方式给单元格赋值

yehf

用CopyFromRecordSet方法,速度要更加快.

liangshu-fu

非常感谢，这正是我想要的。

ljp518

非常感谢！{:soso_e163:}

lin2003_lin

测试一下，显示编译错误：找不到工程或库！？
Sub QueryToExcel(ByVal strQueryName As String, ByVal xlsName As String, ByVal _
                                                                        strShtName As String)

Henry D. Sy

lin2003_lin 发表于 2013-4-11 15:07
测试一下，显示编译错误：找不到工程或库！？
Sub QueryToExcel(ByVal strQueryName As String, ByVal xls ...

需要引用Microsoft Excel 11.0 Object Library