ACCESS对象--查询表中的数据如何导入指定的EXCEL表中

lym321321

VBA方法求教????
谢谢!!!!

（注：用菜单导出方法，本菜会一点，但、在实操中速度不快，并且还无法导入指定的EXCEL表中）


双手
致谢
走过路过的
热心无私的
网络编程高手！！！

[ 本帖最后由 lym321321 于 2008-12-2 00:08 编辑 ]

Henry D. Sy

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

复制代码

调用

1. Private Sub Command0_Click()
   
2.     QueryToExcel "Balance", "balxls", "bal"
   
3. End Sub

复制代码

[ 本帖最后由 Henry D. Sy 于 2008-12-2 00:51 编辑 ]

tmtony

明天要出差，睡不着。
发现 Henry D. Sy 兄还在啊。

先收了QueryToExcel 函数

Henry D. Sy

呵呵，一路顺风。
早点回家。

lym321321

原帖由 Henry D. Sy 于 2008-12-2 00:47 发表
'---------------------------------------------------------------------------------------
' Procedure : QueryToExcel
' DateTime  : 2008-12-2 00:02
' Author    : Henry D. Sy
' Purpose   : strQueryNa ...

刚打开电脑看见
多谢!!!

lgcsee

要好好学习一下！

lhsh

Private Sub Command41_Click()
Dim Expath As String
Dim n As Object
Expath = CurrentProject.Path & "\"
'debug.print Expath
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel9, "工资汇总", Expath & "工资表.XLS", True, "汇总表"
1002 Set n = CreateObject("EXCEL.APPLICATION") '呼叫Excel
1004 n.Visible = True  '显示在屏幕上
1007 n.Workbooks.Open Expath & "工资表.XLS"
End Sub

chaojianan

学习学习，谢谢分享。

horse0918

看不懂

guwenbo

顶帖学习中