Question

我正在使用Access Db将一些信息导出到Excel工作簿。我正在使用输入表单向创建工作表的查询添加日期。如果我创建1张表，则导出有效。如果我在查询转到第二张工作表时创建了多个工作表，则焦点将保留在Excel电子表格中。如果输入日期，则会转到电子表格的单元格A1而不是输入框。任何帮助表示赞赏。

Public Function ExportSpreadSheet(path As String)

Dim xlPath As String, I As Integer
Dim DB As Database 
Dim myrs As Recordset ' Create a recordset to hold the data
Dim strSQL As String 
Dim myExcel As New Excel.Application ' Create Excel with Early binding
Dim wrkbk As Object 
Dim wrksht As Object 
Dim targetworkbook As Excel.Workbook
Dim FileRange, name As String
Dim extraChar, queryForTransfer, searchSheet As String
Dim objXL As Object
Dim objAC As Object
Dim x As Integer
Dim myFileName As String
Dim sheetDate As String
Dim sheetName As String
Dim amtofsheets As Long
Dim s As Long
Dim ctlCurrentControl As Control
Dim strAnswer As String

On Error GoTo Err_ExportSpreadSheet

    DoCmd.SetWarnings False

    xlPath = path

    amtofsheets = InputBox("Enter amount of sheets", "Amount of Sheets")

    Set DB = CurrentDb 
    Set objAC = CreateObject("Access.application", "")
    For s = 1 To amtofsheets

      strAnswer = Forms("Browse1").txtFileSelection
      sheetDate = InputBox("Enter Trade Date of Entries ex 10/04/2017", "Trade Date")

        If s = 1 Then Set objXL = CreateObject("Excel.application", "")
        If s = 1 Then objXL.Visible = True
        If s = 1 Then objXL.DisplayAlerts = True
        If s = 1 Then Set targetworkbook = objXL.Workbooks.Add 
        'Add worksheet if need more than three worksheets

         strSQL = "SELECT FXOpenDeals.city, FXOpenDeals.[As of Date], FXOpenDeals.[Cnt Pty name], FXOpenDeals.[deal number], FXOpenDeals.value, FXOpenDeals.ccy1, FXOpenDeals.[ccy1 amt], FXOpenDeals.ccy2, FXOpenDeals.[ccy2 amt], FXOpenDeals.[unrealized G/L_PV] " _
            & " FROM [A1-Internal_Customers] INNER JOIN FXOpenDeals ON [A1-Internal_Customers].[counterparty number] = FXOpenDeals.[counterparty number] " _
            & " WHERE FXOpenDeals.[trade] = #" & Format(sheetDate, "mm/dd/yyyy") & "#" _
            & " ORDER BY FXOpenDeals.[Cnt Pty name];"

        Set myrs = DB.OpenRecordset(strSQL) 

        If amtofsheets = 1 Or amtofsheets = 2 Then
            For I = 1 To targetworkbook.Worksheets.Count
                sheetName = "Sheet" & I
                Select Case sheetName
                    Case "Sheet2"
                        targetworkbook.Sheets("Sheet2").Delete
                    Case "Sheet3"
                        targetworkbook.Sheets("Sheet3").Delete
                End Select
            Next I
        End If

        If s > 3 Then
        With targetworkbook
            .Sheets.Add After:=Sheets(Worksheets.Count)
            ActiveSheet.name = "Sheet" & s
        End With
        End If

        'Get spreadsheet headers
        x = 0
        For Each Field In myrs.Fields 'RS being my Recordset variable
            targetworkbook.Worksheets("Sheet" & s).Range("A1").Offset(0, x).Value = Field.name
            x = x + 1
        Next Field
        targetworkbook.Worksheets("Sheet" & s).Range("A2").CopyFromRecordset myrs
        targetworkbook.Worksheets("Sheet" & s).Columns("A:K").AutoFit
        'Name Worksheet
        sheetName = Format(sheetDate, "mm-dd")
        targetworkbook.Sheets("Sheet" & s).name = sheetName

    Next s

    DoCmd.SetWarnings False
    myFileName = "Internal Customer FX Deals"
    targetworkbook.SaveAs FileName:=xlPath & myFileName, FileFormat:=xlWorkbookNormal
    targetworkbook.Close SaveChanges:=False
    DoCmd.SetWarnings True

    If Not objXL Is Nothing Then
    objXL.Quit
    objXL.DisplayAlerts = True
    Set objXL = Nothing
    Set myrs = Nothing
    End If

    MsgBox "Internal Customer FX Deals Data successfully Exported", vbOKOnly
Exit_ExportSpreadSheet:
Exit Function
Err_ExportSpreadSheet:

Err.Clear
Resume Exit_ExportSpreadSheet

End Function

Answer 1

在我看来，你无所事事地做了很多工作。除非您想要进行一些格式化，否则不需要自动化Excel。只需通过TransferSpreadsheet将查询导出到Excel。而不是输入框，在查询中使用参数，或者更好的是，使用带有文本框的小表单。

DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "yourQueryName", "FileName", True, "SheetName"

Access DB无法将焦点返回到输入框

1 个答案: