Office中国论坛/Access中国论坛

标题: ACCESS对象--查询表中的数据如何导入指定的EXCEL表中 [打印本页]
作者: lym321321    时间: 2008-12-1 23:47
标题: ACCESS对象--查询表中的数据如何导入指定的EXCEL表中
VBA方法求教????
谢谢!!!!

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


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

[ 本帖最后由 lym321321 于 2008-12-2 00:08 编辑 ]
作者: Henry D. Sy    时间: 2008-12-2 00:47
  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

  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

  22.     Set rs = New ADODB.Recordset

  24.     ' Get the desired data into a recordset
  25.     rs.Open strQueryName, CurrentProject.Connection

  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

  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

  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    时间: 2008-12-2 01:09
明天要出差，睡不着。
发现 Henry D. Sy 兄还在啊。

先收了QueryToExcel 函数
作者: Henry D. Sy    时间: 2008-12-2 08:47
呵呵，一路顺风。
早点回家。
作者: lym321321    时间: 2008-12-2 20:40
原帖由 Henry D. Sy 于 2008-12-2 00:47 发表
'---------------------------------------------------------------------------------------
' Procedure : QueryToExcel
' DateTime  : 2008-12-2 00:02
' Author    : Henry D. Sy
' Purpose   : strQueryNa ...




刚打开电脑看见
多谢!!!
作者: lgcsee    时间: 2009-2-9 14:28
要好好学习一下！
作者: lhsh    时间: 2009-2-12 15:11
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    时间: 2009-2-12 17:43
学习学习，谢谢分享。
作者: horse0918    时间: 2009-2-13 12:09
看不懂
作者: guwenbo    时间: 2009-3-6 16:10
顶帖学习中
作者: guwenbo    时间: 2009-3-6 16:11
顶帖学习中
作者: jackysu78    时间: 2009-3-12 17:44
这是讲的导出到EXCEL模版的问题吧，下载学习先。谢谢！
作者: lbf306    时间: 2010-7-6 14:29
顶贴学习啊
作者: weikitwong    时间: 2010-7-16 22:02
收下，3K



欢迎光临 Office中国论坛/Access中国论坛 (http://www.office-cn.net/) Powered by Discuz! X3.3