在Access中编码时，每个Excel函数之前需要的Excel.application对象variables
我有一些代码访问打开.htm文件，将其保存为.xlsx然后操纵数据一点，然后导入到Access中的表中。 我用它来使用
Dim XLapp as Excel.Application Set XLapp = New Excel.Application 那么我可以在Excel中完成所有的操作，而不必将XLapp放在每个命令前面。 但问题是，我创build一个新的Excel实例，每次运行代码，遇到对象'_global'失败“的错误”的方法'工作表'每隔一次运行“（有人已经提到这个问题），所以我用
Public Function GetExcelObject() As Object On Error Resume Next Dim xlo As Object ' Try to get running instance of Excel Set xlo = GetObject(, "Excel.Application") If xlo Is Nothing Then Set xlo = CreateObject("Excel.Application") End If Set GetExcelObject = xlo End Function
只创build一个Excel实例。 但是现在我的代码变成这样了
'delete columns that will not be used ws.Range("F:J,S:V").Select XLapp.Selection.Delete XLapp.Range("A1").Select XLapp.Selection.End(xlToRight).Select XLapp.ActiveCell.Offset(0, 1).Select XLapp.Selection.Value = "Server" lastrow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row ColumnNum = XLapp.ActiveCell.Column XLapp.Range(XLapp.ActiveCell.Offset(1, 0), XLapp.Cells(lastrow, ColumnNum)).Select XLapp.Selection.Value = UCase(Right(ws.Name, (Len(ws.Name) - InStr(1, ws.Name, "_")))) XLapp.Range("B1").Select XLapp.Selection.Value = "Client_Name" XLapp.Columns("J:J").Select XLapp.Selection.Insert Shift:=xlToRight
我必须把XLapp放在每一个命令前面。
整个代码如下
Option Compare Database Option Explicit Public fso, oFolder, oSubfolder, ofile, queue As Collection Public sourceCol As Integer, rowCount As Integer, currentRow As Integer Public currentRowValue As String Public objExcelAddwb As Object Public wb As Excel.Workbook Public ws As Excel.Worksheet Public lastrow As Long Public ColumnNum As Long Public SQL As String Public Updated_SQL As String Public CurrentDB As Database Public StatusVar As Variant Public XLapp As Excel.Application Private Sub btn_Import_Report_Click() 'Set objXLapp = CreateObject("Excel.Application") Set XLapp = GetExcelObject() 'Set wb = objXLapp.Workbooks.Add 'Set XLapp = Excel.Application Set fso = CreateObject("Scripting.FileSystemObject") Set queue = New Collection 'objXLapp.Visible = False 'Set obExcel = CreateObject("Excel.Application") queue.Add fso.GetFolder(CurrentProject.Path & "\Process_Report") 'obviously replace Do While queue.Count > 0 Set oFolder = queue(1) queue.Remove 1 'dequeue '...insert any folder processing code here... For Each oSubfolder In oFolder.SubFolders queue.Add oSubfolder 'enqueue Next oSubfolder For Each ofile In oFolder.Files StatusVar = SysCmd(4, "Processing " & ofile) If InStrRev(ofile, "Account") > 0 Then Import_Accounts_Report fso, oFolder, oSubfolder, ofile, queue, wb, ws, XLapp, lastrow, ColumnNum ElseIf InStrRev(ofile, "Closed") > 0 Then Import_Closed_Trade_Report fso, oFolder, oSubfolder, ofile, queue, wb, ws, XLapp, lastrow, ColumnNum ElseIf InStrRev(ofile, "Raw") > 0 Then Import_Raw_Report fso, oFolder, oSubfolder, ofile, queue, wb, ws, XLapp, lastrow, ColumnNum ElseIf InStrRev(ofile, "History") > 0 Then Import_History_Report fso, oFolder, oSubfolder, ofile, queue, wb, ws, XLapp, lastrow, ColumnNum ElseIf InStrRev(ofile, "Orders") > 0 Then Import_Orders_Report fso, oFolder, oSubfolder, ofile, queue, wb, ws, XLapp, lastrow, ColumnNum ElseIf InStrRev(ofile, "Summary") > 0 Then Import_Position_Summary_Report fso, oFolder, oSubfolder, ofile, queue, wb, ws, XLapp, lastrow, ColumnNum End If Next Loop StatusVar = SysCmd(5) Set ws = Nothing Set wb = Nothing 'Set Selection = Nothing Set ofile = Nothing Set fso = Nothing Set queue = Nothing Set oFolder = Nothing Set oSubfolder = Nothing 'XLapp.Quit Set XLapp = Nothing Form_Main_Menu.Visible = True MsgBox ("All Reports Imported") End Sub
然后在另一个导入模块中：
Sub Import_Accounts_Report(fso, oFolder, oSubfolder, ofile, queue As Collection, wb As Excel.Workbook, ws As Excel.Worksheet, XLapp As Excel.Application, lastrow As Long, ColumnNum As Long) Set wb = XLapp.Workbooks.Open(ofile) XLapp.DisplayAlerts = False wb.SaveAs FileName:=CurrentProject.Path & "\Ready_To_Import\" & Left(wb.Name, Len(wb.Name) - 4), FileFormat:=51 XLapp.DisplayAlerts = True Set ws = wb.Sheets(1) 'delete previous accounts report data DoCmd.SetWarnings False If Not IsNull(DLookup("Name", "Msysobjects", "Name='tbl_Accounts_Report'")) Then SQL = "DELETE tbl_Accounts_Report.Server" & _ " FROM tbl_Accounts_Report" & _ " WHERE (((tbl_Accounts_Report.Server)='Replace'))" Updated_SQL = Replace(SQL, "Replace", Right(ws.Name, (Len(ws.Name) - InStr(1, ws.Name, "_")))) DoCmd.RunSQL Updated_SQL Else CurrentDB.Execute "Create Table Accounts_Report" End If DoCmd.SetWarnings True 'delete the first row ws.Activate ws.Range("1:1").Select XLapp.Selection.Delete 'Remove space in numbers XLapp.DisplayAlerts = False XLapp.Columns("Q:R").Select XLapp.Selection.Replace What:=" ", Replacement:="", LookAt:=xlPart, _ SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _ ReplaceFormat:=False XLapp.DisplayAlerts = True 'delete columns that will not be used ws.Range("F:J,S:V").Select XLapp.Selection.Delete XLapp.Range("A1").Select XLapp.Selection.End(xlToRight).Select XLapp.ActiveCell.Offset(0, 1).Select XLapp.Selection.Value = "Server" lastrow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row ColumnNum = XLapp.ActiveCell.Column XLapp.Range(XLapp.ActiveCell.Offset(1, 0), XLapp.Cells(lastrow, ColumnNum)).Select XLapp.Selection.Value = UCase(Right(ws.Name, (Len(ws.Name) - InStr(1, ws.Name, "_")))) XLapp.Range("B1").Select XLapp.Selection.Value = "Client_Name" XLapp.Columns("J:J").Select XLapp.Selection.Insert Shift:=xlToRight 'unmerge the spreadsheet XLapp.Columns("I:I").Select XLapp.Selection.UnMerge With Selection .VerticalAlignment = xlBottom .WrapText = False .Orientation = 0 .AddIndent = False .IndentLevel = 0 .ShrinkToFit = False .ReadingOrder = xlContext .MergeCells = False End With 'separate date and time and format date and time XLapp.DisplayAlerts = False Columns("I:I").Select Selection.TextToColumns Destination:=Range("I1"), DataType:=xlDelimited, _ TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=False, _ Semicolon:=False, Comma:=False, Space:=True, Other:=False, FieldInfo _ :=Array(Array(1, 5), Array(2, 1)), TrailingMinusNumbers:=True XLapp.DisplayAlerts = True Columns("I:I").Select Selection.NumberFormat = "m/d/yyyy" Columns("J:J").Select Selection.NumberFormat = "[$-F400]h:mm:ss AM/PM" Range("I1").Select Selection.Value = "Reg_Date" Range("J1").Select Selection.Value = "Reg_Time" 'import to the DB DoCmd.TransferSpreadsheet acImport, , "tbl_Accounts_Report", CurrentProject.Path & "\Ready_To_Import\" & wb.Name, True XLapp.DisplayAlerts = False wb.Close XLapp.DisplayAlerts = True Set ws = Nothing Set wb = Nothing XLapp.Quit Set XLapp = Nothing End Sub
有人请帮忙。
谢谢
目前，您的XLapp代码块不起作用，因为Excel.Application对象没有.Range ， .Selection ， .ActiveCell等方法。 这些是Excel工作表级别的方法。 因此，而不是XLapp.Range("A1").Select ，正确的引用将是： XLwks.Range("A1").Select 。
有趣的是，您已经设置了工作簿和工作表对象：
Set wb = XLapp.Workbooks.Open(ofile) ... Set ws = wb.Sheets(1)
因此，继续使用工作表对象，而不是XLapp 。 并避免重复ws.前缀ws. ，考虑使用With子句。 另外，您可以删除许多select ：
XLapp.DisplayAlerts = True 'delete columns that will not be used With ws .Range("F:J,S:V").Select XLapp.Selection.Delete .Range("A1").End(xlToRight).Offset(0, 1) = "Server" lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row ColumnNum = .ActiveCell.Column .Range(.ActiveCell.Offset(1, 0), .Cells(lastrow, ColumnNum)) _ = UCase(Right(.Name, (Len(.Name) - InStr(1, .Name, "_")))) .Range("B1") = "Client_Name" .Columns("J:J").Insert Shift:=xlToRight 'unmerge the spreadsheet .Columns("I:I").UnMerge End With
此外，请确保所有Excel常量都正确声明，因为它们不在debugging器将提醒您的MS Access对象库中已知：
Const xlToRight = -4161 Const xlUp = -4162