ACCESS数据导出到指定的工作表中

Henry D. Sy

可以的吧
你把你的例子传上来

Henry D. Sy

1. '---------------------------------------------------------------------------------------
   
2. ' Procedure : QueryToExcel
   
3. ' DateTime  : 2008-12-2 00:02
   
4. ' Author    : Henry D. Sy
   
5. ' Purpose   : QueryToExcel "查询名称", "工作簿名称", "工作表名称"
   
6. '             xls文件要与Access文件放在同一个文件夹
   
7. '---------------------------------------------------------------------------------------
   
8. '
   
9. Sub QueryToExcel(ByVal strQueryName As String, ByVal XlName As String, ByVal _
   
10.                  XlShtName As String)
    
11. ' Send the Query results to Excel
    
12. ' for further analysis
    
13. 
    
14.     Dim rs As New ADODB.Recordset
    
15.     Dim XlApp As New Excel.Application
    
16.     Dim XlWb As Excel.Workbook
    
17.     Dim fld As ADODB.Field
    
18.     Dim intCol As Integer
    
19.     Dim intRow As Integer
    
20. 
    
21.     ' Get the desired data into a recordset
    
22. 
    
23.     On Error GoTo QueryToExcel_Error
    
24. 
    
25.     rs.Open strQueryName, CurrentProject.Connection
    
26. 
    
27. 
    
28.     ' Open a  worksheet
    
29.     Set XlWb = XlApp.Workbooks.Open(CurrentProject.Path & "" & XlName & _
    
30.                                     ".xls")
    
31.     XlWb.Worksheets(XlShtName).Activate
    
32. 
    
33.     ' Copy the data
    
34.     ' First the field names
    
35.     For intCol = 0 To rs.Fields.Count - 1
    
36.         Set fld = rs.Fields(intCol)
    
37.         XlWb.Worksheets(XlShtName).Cells(1, intCol + 1) = fld.Name
    
38.     Next intCol
    
39.     ' Now the actual data
    
40.     intRow = 2
    
41.     Do Until rs.EOF
    
42.         For intCol = 0 To rs.Fields.Count - 1
    
43.             XlWb.Worksheets(XlShtName).Cells(intRow, intCol + 1) = _
    
44.             rs.Fields(intCol).Value
    
45.         Next intCol
    
46.         rs.MoveNext
    
47.         intRow = intRow + 1
    
48.     Loop
    
49. 
    
50.     ' Make the worksheet visible
    
51.     XlApp.Visible = True
    
52.     rs.Close
    
53.     Set rs = Nothing
    
54. 
    
55.     On Error GoTo 0
    
56.     Exit Sub
    
57. 
    
58. QueryToExcel_Error:
    
59. 
    
60.     MsgBox "Error " & Err.Number & " (" & Err.Description & ")"
    
61. End Sub
    
62. 
    

复制代码