Office中国论坛/Access中国论坛

标题: ACCESS数据导出到指定的工作表中 [打印本页]
作者: yuayua23    时间: 2016-11-10 11:09
标题: ACCESS数据导出到指定的工作表中
可不可以将查询的数据结果导出到指定的工作表中，比如客户“A”的查询数据导出到“客户”工作薄中的"A"的工作表中?论坛中以前有个差不多的实例找不到了，那歌大神有的提供一下，谢谢
作者: Henry D. Sy    时间: 2016-11-10 15:23
可以的吧
你把你的例子传上来
作者: Henry D. Sy    时间: 2016-11-10 15:49
  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

  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

  21.     ' Get the desired data into a recordset

  23.     On Error GoTo QueryToExcel_Error

  25.     rs.Open strQueryName, CurrentProject.Connection


  28.     ' Open a  worksheet
  29.     Set XlWb = XlApp.Workbooks.Open(CurrentProject.Path & "" & XlName & _
  30.                                     ".xls")
  31.     XlWb.Worksheets(XlShtName).Activate

  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

  50.     ' Make the worksheet visible
  51.     XlApp.Visible = True
  52.     rs.Close
  53.     Set rs = Nothing

  55.     On Error GoTo 0
  56.     Exit Sub

  58. QueryToExcel_Error:

  60.     MsgBox "Error " & Err.Number & " (" & Err.Description & ")"
  61. End Sub

复制代码
作者: yuayua23    时间: 2016-11-21 11:55
Henry D. Sy 发表于 2016-11-10 15:49

非常感谢版主的帮助



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