導(dǎo)出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

復(fù)制代碼

1. Private Sub Command0_Click()
   
2.     QueryToExcel "要導(dǎo)出的查詢（表）名", "工作簿名", "工作表名"
   
3. End Sub

復(fù)制代碼

簡

哎，不錯不錯，簡化成函數(shù)了，以往我都是引用紅塵版主那個導(dǎo)出excel的例子，你的比紅塵版主的要簡單些，紅塵版主對錯誤的處理要全面些。

Benjamin_luk

數(shù)據(jù)量大的話，建議用數(shù)組的方式給單元格賦值

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 發(fā)表于 2013-4-11 15:07
測試一下，顯示編譯錯誤：找不到工程或庫��？
Sub QueryToExcel(ByVal strQueryName As String, ByVal xls ...

需要引用Microsoft Excel 11.0 Object Library