Question

我正在使用Access 2013并将数据导出到exisitng Excel 2010工作簿。我正在使用以下代码（传递查询，工作表和excel文件名）。一切都很好：

Public Function SendTQ2XLWbSheetSizeRange(strTQName As String, strSheetName As String, strFilePath As String)
' strTQName is the name of the table or query you want to send to Excel
' strSheetName is the name of the sheet you want to send it to
' strFilePath is the name and path of the file you want to send this data into.

    Dim rst As DAO.Recordset
    Dim ApXL As Object
    Dim xlWBk As Object
    Dim xlWSh As Object
    Dim fld As DAO.Field
    Dim strPath As String
    Const xlCenter As Long = -4108
    Const xlBottom As Long = -4107
    On Error GoTo err_handler

    strPath = strFilePath

    Set rst = CurrentDb.OpenRecordset(strTQName)

    Set ApXL = CreateObject("Excel.Application")

    Set xlWBk = ApXL.Workbooks.Open(strPath)

    ApXL.Visible = True

    Set xlWSh = xlWBk.Worksheets(strSheetName)

    xlWSh.Activate

    xlWSh.Range("A5").Select

    For Each fld In rst.Fields
        ApXL.ActiveCell = fld.Name
        ApXL.ActiveCell.Offset(0, 1).Select
    Next

    rst.MoveFirst

    xlWSh.Range("A6").CopyFromRecordset rst

    xlWSh.Range("1:1").Select
    ' This is included to show some of what you can do about formatting.  You can comment out or delete
    ' any of this that you don't want to use in your own export.
    With ApXL.Selection.Font
        .Name = "Arial"
        .Size = 12
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
    End With

    ApXL.Selection.Font.Bold = True

    With ApXL.Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .MergeCells = False
    End With

    ' selects all of the cells
    ApXL.ActiveSheet.Cells.Select

    ' does the "autofit" for all columns
    ApXL.ActiveSheet.Cells.EntireColumn.AutoFit

    ' selects the first cell to unselect all cells
    xlWSh.Range("A1").Select

    rst.Close

    Set rst = Nothing

Exit_SendTQ2XLWbSheet:
    Exit Function

err_handler:
    DoCmd.SetWarnings True
    MsgBox Err.Description, vbExclamation, Err.Number
    Resume Exit_SendTQ2XLWbSheet
End Function

现在我需要将另一个查询导出到同一Excel文件中的其他工作簿。问题是上面的代码打开了Excel文件，所以如果我再次调用该过程，它会打开Excel的另一个只读副本。我该如何解决这个问题？总计我需要在1个Excel文件中对3个不同的工作表执行3次导出。有人可以帮忙吗？

Answer 1

我会使用三个程序。第一个只是标识要打开哪个文件以及哪个查询在哪个表上。

这将在Sheet1上放置Query1，在Sheet2上放置Query2。它使用ParamArray，因此您可以根据需要添加任意数量的工作表/查询对：

Public Sub ProcessExcel()

    SendToExcel "<full path to Excel file>", "Sheet1", "Query1", "Sheet2", "Query2"

End Sub

第二个过程设置对Excel的引用，打开工作簿，然后开始处理ParamArray。工作表名称用于创建对实际工作表的引用，然后将其传递给下一个过程。

Public Sub SendToExcel(sFilePath As String, ParamArray ShtQry() As Variant)

    Dim oXL As Object   'Ref to Excel.
    Dim oWB As Object   'Ref to workbook.
    Dim x As Long       'General counter

    'Get or create reference to Excel.
    On Error Resume Next
    Set oXL = GetObject(, "Excel.Application")
    If Err.Number <> 0 Then
        Err.Clear
        On Error GoTo Err_Handle
        Set oXL = CreateObject("Excel.Application")
    End If
    On Error GoTo Err_Handle

    Set oWB = oXL.Workbooks.Open(sFilePath)

    For x = LBound(ShtQry) To UBound(ShtQry) Step 2
        SendTQ2XLWbSheetSizeRange oWB.worksheets(CStr(ShtQry(x))), CStr(ShtQry(x + 1))
    Next x

Exit Sub

Err_Handle:

End Sub

最后一个程序打开记录集并将所有内容粘贴到正确的工作表上：

Public Sub SendTQ2XLWbSheetSizeRange(oWrkSht As Object, sTQName As String)
    Dim rst As DAO.Recordset
    Dim db As DAO.Database
    Dim x As Long

    Set db = CurrentDb
    Set rst = db.OpenRecordset(sTQName)

    With oWrkSht
        'Place field headings.
        For x = 0 To rst.Fields.Count - 1
            .cells(5, x + 1) = rst.Fields(x).Name
        Next x
        'Place values.
        .Range("A6").CopyFromRecordset rst
    End With

    rst.Close

    Set rst = Nothing
    Set db = Nothing

End Sub

我错过了代码中的大量错误检查 - 确保工作表存在，数组保存工作表/查询对以及我甚至没有考虑的批次。

注意：看不到一个Select或Activate - 只需参考表格。

Answer 2

这听起来不对：＆＃39;将另一个查询导出到同一个Excel文件中的另一个工作簿＆＃39;。如何将不同表的内容导出到一个Excel文件，但将每个表的结果放在同一个Excel文件中的单独表中。您可以轻松修改代码以将查询导出到单独的Excel工作表，而不是导出表。

Option Compare Database
Option Explicit
Private Sub Command0_Click()

  Dim strFile As String
  Dim varItem As Variant

    strFile = InputBox("Designate the path and file name to export to...", "Export")

    If (strFile = vbNullString) Then Exit Sub

    For Each varItem In Me.List0.ItemsSelected
        DoCmd.TransferSpreadsheet transferType:=acExport, _
                                  spreadsheetType:=acSpreadsheetTypeExcel9, _
                                  tableName:=Me.List0.ItemData(varItem), _
                                  FileName:=strFile
    Next

    MsgBox "Process complete.", vbOKOnly, "Export"
End Sub
Private Sub Form_Open(Cancel As Integer)
  Dim strTables As String
  Dim tdf As TableDef
  ' Reference: MS DAO 3.6
  ' Properties > All > Row Source Type = Value List
    For Each tdf In CurrentDb.TableDefs
        If (Left(tdf.Name, 4) <> "MSys") Then
            strTables = strTables & tdf.Name & ","
        End If
    Next
    strTables = Left(strTables, Len(strTables) - 1)

    Me.List0.RowSource = strTables
End Sub

将ListBox添加到表单，并在同一表单上添加一个按钮，然后以这种方式运行。

Answer 3

感谢大家的客气话和建议。我已经和@Cody G.一起去了第二个建议，每次都关闭了excel文件，所以只需添加

xlWBk.Close True

Set xlWBk = Nothing

ApXL.Quit

Set ApXL = Nothing

每一次。

访问多个导出到现有Excel工作簿

3 个答案: