如何通过 Access VBA 正确访问 Excel 文件

Posted 2023-05-07

【中文标题】如何通过 Access VBA 正确访问 Excel 文件

【英文标题】：How do I properly access Excel Files through Access VBA

【发布时间】：2021-02-12 20:31:38

【问题描述】：

我是一个非常新手的编码器，正在编写一个程序来从 Access 表中提取一些数据并将其放入 Excel 工作表中。 Excel 工作簿创建正确，但是当我去保存它时，我得到一个

VBA 运行时错误“1004” - 无法访问“检查和传输导入” 文件 02122021.xlsx'。

当我尝试打开文件时，我收到一条消息，指出有人正在使用该文件，但我可以将其打开为“仅就绪”。问题是没有其他人在使用该文件。我做错了什么？

'Transfers the checks/transfers from the two tables to an Excel sheet
Dim objXLApp As excel.Application
Dim objXLBook As excel.Workbook
Dim wS As excel.Worksheet
Dim rowCount As Integer
Dim rstChecks As New ADODB.Recordset
Dim rstTransfer As New ADODB.Recordset
    
Dim qdF As DAO.QueryDef
Dim rsT As DAO.Recordset

Dim qdF1 As DAO.QueryDef
Dim rsT1 As DAO.Recordset

Set qdF = CurrentDb.QueryDefs("tbl_BankImportChecks Query") ' Gets all fields from Table1
Set qdF1 = CurrentDb.QueryDefs("tbl_BankImportTransfers Query") ' Gets 401(k) contribution and match information

Set rsT = qdF.OpenRecordset
Set rsT1 = qdF1.OpenRecordset

rsT.MoveLast
rsT.MoveFirst
rsT1.MoveLast
rsT1.MoveFirst

Set objXLApp = CreateObject("Excel.Application")
objXLApp.Workbooks.Add
objXLApp.Visible = True

Set wS = objXLApp.Worksheets("Sheet1")

wS.NaMe = "Checks" & Format(Me.DTPicker8.Value, "mmdd")
objXLApp.Sheets("Checks" & Format(Me.DTPicker8.Value, "mmdd")).Activate

wS.Range("A1").Value = "Bank Account"
wS.Range("B1").Value = "Payee"
wS.Range("C1").Value = "Check Date"
wS.Range("D1").Value = "Check Number"
wS.Range("E1").Value = "Check Memo"
wS.Range("F1").Value = "Address Line 1"
wS.Range("G1").Value = "Address Line 2"
wS.Range("H1").Value = "Address City"
wS.Range("I1").Value = "Address State"
wS.Range("J1").Value = "Address Zip"
wS.Range("K1").Value = "Expenses Account"
wS.Range("L1").Value = "Expenses Amount"
wS.Range("M1").Value = "Expenses Memo"
wS.Range("N1").Value = "Expenses Customer Job"
wS.Range("O1").Value = "Not Used"
wS.Range("P1").Value = "Temp Type"
wS.Range("Q1").Value = "Paycheck Amount"
wS.Range("R1").Value = "State"

rowCount = 2

Do While Not rsT.EOF
    wS.Range("A" & rowCount).Value = rsT.Fields(4).Value 'Bank Account (11100)
    wS.Range("B" & rowCount).Value = rsT.Fields(0).Value 'Vendor
    wS.Range("C" & rowCount).Value = rsT.Fields(2).Value 'Check Date
    wS.Range("D" & rowCount).Value = "EFT"
    wS.Range("E" & rowCount).Value = rsT.Fields(3).Value ' Check Memo
    wS.Range("K" & rowCount).Value = rsT.Fields(5).Value 'Expense Account
    wS.Range("L" & rowCount).Value = Abs(Val(rsT.Fields(1).Value)) 'Check Amount
    rowCount = rowCount + 1
    rsT.MoveNext
Loop

Set wS = objXLApp.Worksheets.Add
Set wS = objXLApp.Worksheets("Sheet2")
wS.NaMe = "Transfers" & Format(Me.DTPicker8.Value, "mmdd")
objXLApp.Sheets("Transfers" & Format(Me.DTPicker8.Value, "mmdd")).Activate

wS.Range("A1").Value = "To Account"
wS.Range("B1").Value = "From Account"
wS.Range("C1").Value = "Transfer Date"
wS.Range("D1").Value = "Transfer Memo"
wS.Range("E1").Value = "Transfer Amount"

rowCount = 2
Do While Not rsT1.EOF
    wS.Range("A" & rowCount).Value = rsT1.Fields(0).Value 'To Account
    wS.Range("B" & rowCount).Value = rsT1.Fields(1).Value 'From Account
    wS.Range("C" & rowCount).Value = rsT1.Fields(2).Value 'Transfer Date
    wS.Range("D" & rowCount).Value = Abs(Val(rsT1.Fields(3).Value)) 'Amount
    wS.Range("E" & rowCount).Value = rsT1.Fields(4).Value 'Transfer Memo
    rowCount = rowCount + 1
    rsT1.MoveNext
Loop
objXLApp.ActiveWorkbook.SaveAs "C:\Users\Jim's Surface Pro 5\Dropbox\Working Folder\Jim dePrado\Quickbooks Access Files\" & "Checks and Transfers Import File " & Format(Now(), "mmddyyyy")
objXLApp.ActiveWorkbook.Close

Set qdF = Nothing
Set qdF1 = Nothing
Set rsT = Nothing
Set rsT1 = Nothing
Set objXLApp = Nothing
Set objXLBook = Nothing
Set wS = Nothing

MsgBox "done"

【问题讨论】：

您是否尝试在文件名中添加文件扩展名？您是否尝试过包含 FileFormat？ docs.microsoft.com/en-us/office/vba/api/excel.xlfileformat

抱歉回复晚了。我们与 COVID 发生了一场小较量。我们现在都很好，这有效。非常感谢您的帮助！

【参考方案1】：

You always must be extremely specific with Excel objects.

因此，您可能需要：

Set objXLApp = CreateObject("Excel.Application")
Set objXLBook = objXLApp.Workbooks.Add

Set wS = objXLBook.Worksheets(1) ' Sheet name is localised.
wS.Name = "Checks" & Format(Me.DTPicker8.Value, "mmdd")
' Should not be needed.
' objXLApp.Sheets("Checks" & Format(Me.DTPicker8.Value, "mmdd")).Activate

' ---

objXLBook.SaveAs "C:\Users\Jim's Surface Pro 5\Dropbox\Working Folder\Jim dePrado\Quickbooks Access Files\" & "Checks and Transfers Import File " & Format(Now(), "mmddyyyy")

Set wS = Nothing
Set objXLBook = Nothing

objXLApp.Quit
Set objXLApp = Nothing