在同一个Excel上运行两个VBA代码

Question

我在Access中使用VBA修改使用宏1的Excel工作表，并在使用宏2的表格中输入它。当我连续运行这两个代码时，我的系统卡在一个循环中，但运行良好，如果我运行一个宏并运行宏2后重新启动Microsoft访问应用程序。有时，我正在运行我的代码的Excel文件获得一个弹出框启用读/写访问..可以有人帮助我吗？

宏1

Function Clean() 


Dim CurrFilePath, PathName, Week As String 
Dim Filename 
Dim OpenExcel As Object 
Set OpenExcel = CreateObject("Excel.Application") 
OpenExcel.Visible = False 
Dim OpenWorkbook, WS As Object 
Dim i, j As Integer 
Dim Count_WS As Integer 
OpenExcel.Quit 
CurrFilePath = Application.CurrentProject.path 
StartTime = Timer 

Week = InputBox("Enter the week for the data import e.g. 34") 
PathName = CurrFilePath & "\Direct Deliveries\Week " & Week & "\" 
Example = CurrFilePath & "\Direct Deliveries\Week " & Week 
Confirm: 
    Confirm_Folder = MsgBox("Does the Direct Deliveries info exist in " & PathName & " path", vbYesNo) 
    If Confirm_Folder = vbNo Then 
    path = InputBox("Locate Direct Deliveries .xlsx on your System and Copy the Dir path here e.g." & Example) 
    PathName = path & "\" 
    GoTo Confirm 
    End If 

Filename = Dir(PathName & "*.xlsx") 



Do While Len(Filename) > 0 
    Set OpenExcel = CreateObject("Excel.Application") 
    OpenExcel.Visible = False 
    OpenExcel.EnableEvents = False 
    OpenExcel.ScreenUpdating = False 
    'Variables to track first cell 
    i = 0 
    j = 0 
    PathFile = PathName & Filename 
    Set OpenWorkbook = OpenExcel.Workbooks.Open(PathFile) 

    For Each WS In OpenWorkbook.Worksheets 
     'If condition to check correct worksheets 
     On Error Resume Next 
     If Range("A1").Value = "Carrier SCAC" And Range("D1").Value = "Trip ID" Then 

      'Loop to fill blank TripIDs 
      For Each Cell In WS.UsedRange.Columns(4).Cells 
       ' For blank cells, set them to equal the cell above 
       If WS.Cells(Cell.Row, 1) <> "ABCD" And Not IsEmpty(WS.Cells(Cell.Row, 9)) Then 
         If i <> 0 Then 
          If (Len(Cell.Text) = 0) And PreviousCell <> "Trip ID" And Cell.Row Then 
           Cell.Value = PreviousCell 
          End If 

         End If 
         PreviousCell = Cell 
         i = i + 1 
       End If 
      Next Cell 

      'Loop to fill blank SCAC Codes 
      For Each CarrierCell In WS.UsedRange.Columns(1).Cells 
       ' For blank cells, set them to equal the cell above 
       If j <> 0 Then 

        If (Len(CarrierCell.Text) = 0) And PreviousCell <> "Carrier SCAC" And PreviousCell <> "ABCD" And Not IsEmpty(WS.Cells(CarrierCell.Row, 4)) Then 
         CarrierCell.Value = PreviousCell 
        End If 

       End If 
       PreviousCell = CarrierCell 
       j = j + 1 
      Next CarrierCell 
     End If 
     Count_WS = Count_WS + 1 
    Next WS 
    Filename = Dir() 
    OpenWorkbook.Close SaveChanges:=True 
    Set OpenWorkbook = Nothing 
    OpenExcel.Quit 
    Set OpenExcel = Nothing 


Loop 



'Display the end status 
TotalTime = Format((Timer - StartTime)/86400, "hh:mm:ss") 
Application.Echo True 

DeleteImportErrTables 

End Function 

宏2

'-------------------------------------------------------- 
' Author: Akanksha Goel 
' The code imports Direct Deliveries erroneous excel templates to Access Database 
'------------------------------------------------------------ 
' 
'------------------------------------------------------------ 
Function ListErrBeforeImports() 
Dim OpenExcel As Object 
Set OpenExcel = CreateObject("Excel.Application") 
OpenExcel.Visible = False 
Dim PathFile As String, Filename As String, PathName As String 
Dim TableName As String 
Dim HasFieldNames As Boolean 
Dim OpenWorkbookED As Object 
Dim SQL, CurrFilePath As String 
Dim SQLcreate, SQLAlter, SQLSet As String 
Dim SQL2, SQL3 As String 
Dim Count_Templates As Integer 

StartTime = Timer 
OpenExcel.Quit 


'Turn Off the warnings and screen updating 
DoCmd.SetWarnings False 
Application.Echo False 
OpenExcel.EnableEvents = False 
OpenExcel.ScreenUpdating = False 


CurrFilePath = Application.CurrentProject.path 
Week = InputBox("Enter the week for the data import e.g. 34") 
PathName = CurrFilePath & "\Direct Deliveries\Week " & Week & "\" 
Example = CurrFilePath & "\Direct Deliveries\Week " & Week 
Confirm: 
    Confirm_Folder = MsgBox("Does the Direct Deliveries info exist in " & PathName & " path", vbYesNo) 
    If Confirm_Folder = vbNo Then 
    path = InputBox("Locate Direct Deliveries .xlsx on your System and Copy the Dir path here e.g." & Example) 
    PathName = path & "\" 
    GoTo Confirm 
    End If 

HasFieldNames = True 


TableName = "TempTable" 
Filename = Dir(PathName & "*.xlsx") 
PathFile = PathName & Filename 
'Arguments for function AssignTablesToGroup() 
Dim Arg1 As String 
Dim Arg2 As Integer 
Arg1 = "EmptyDeliveryDates_TripsWeek" & Week 
Call DeleteTable(Arg1) 
Arg2 = 383 
SQLcreate = "Create Table EmptyDeliveryDates_TripsWeek" & Week & " (TripID Text, ShipToZip Text, ArriveDelivery Text, Carrier Text, SourceWorkbook Text);" 
DoCmd.RunSQL SQLcreate 
'Assign Error Table to 'Errors in DirectDeliveries Excels' Group 
Call AssignToGroup(Arg1, Arg2) 

'Arguments for function AssignTablesToGroup() 
Dim Arg3 As String 
Arg3 = "InvalidZip_TripsWeek" & Week 
DeleteTable Arg3 
Arg2 = 383 
SQLcreate = "Create Table InvalidZip_TripsWeek" & Week & " (TripID Text, ShipToZip Text, ArriveDelivery Text, Carrier Text, SourceWorkbook Text);" 
DoCmd.RunSQL SQLcreate 
'Assign Error Table to 'Errors in DirectDeliveries Excels' Group 
Call AssignToGroup(Arg3, Arg2) 

'Arguments for function AssignTablesToGroup() 
Dim Arg4 As String 
Arg4 = "InvalidTrip_TripsWeek" & Week 
DeleteTable Arg4 
Arg2 = 383 
SQLcreate = "Create Table InvalidTrip_TripsWeek" & Week & " (TripID Text, ShipToZip Text, ArriveDelivery Text, Carrier Text, SourceWorkbook Text);" 
DoCmd.RunSQL SQLcreate 
'Assign Error Table to 'Errors in DirectDeliveries Excels' Group 
Call AssignToGroup(Arg4, Arg2) 



Do While Len(Filename) > 0 
     Set OpenExcel = CreateObject("Excel.Application") 
     OpenExcel.Visible = False 
     OpenExcel.EnableEvents = False 
     OpenExcel.ScreenUpdating = False 

     PathFile = PathName & Filename 
     Set OpenWorkbookED = OpenExcel.Workbooks.Open(PathFile, ReadOnly) 
     Set WS_Book = OpenWorkbookED.Worksheets 
     DeleteTable "TempTable" 
     'Loop through Worksheets in each template workbook 
     For Each WS In WS_Book 
     WorksheetName = WS.Name 
     x = WS.Range("A1") 
      If WS.Range("A1") = "Carrier SCAC" Then 
      'Get the used records in worksheet 
       GetUsedRange = WS.UsedRange.Address(0, 0) 
       'Import records from worksheet into Access Database table 
       DoCmd.TransferSpreadsheet acImport, 10, "TempTable", PathFile, HasFieldNames, WorksheetName & "!" & GetUsedRange 
       SQLAlter = "ALTER TABLE TempTable ADD COLUMN SourceBook TEXT(100)" 
       DoCmd.RunSQL SQLAlter 
       SQLSet = "UPDATE TempTable SET TempTable.SourceBook = '" & Filename & "' where ([Arrive Delivery]) is NULL or len([Arrive Delivery])<2 or len([Trip ID])<8 or len([Ship to Zip])<5;" 
       DoCmd.RunSQL SQLSet 
       SQL = "INSERT INTO " & Arg4 & "(TripID, ShipToZip, ArriveDelivery, Carrier, SourceWorkbook) Select Distinct [Trip ID], [Ship to Zip], [Arrive Delivery], [Carrier SCAC], SourceBook FROM TempTable WHERE len([Trip ID])<8 and len([Ship To Zip])>0 and len([Arrive Delivery])>0;" 
       DoCmd.RunSQL SQL 
       SQL2 = "INSERT INTO " & Arg3 & "(TripID, ShipToZip, ArriveDelivery, Carrier, SourceWorkbook) Select Distinct [Trip ID], [Ship to Zip], [Arrive Delivery], [Carrier SCAC], SourceBook FROM TempTable WHERE len([Ship To Zip])<5 and len([Arrive Delivery])>0 and len([Trip ID])>0;" 
       DoCmd.RunSQL SQL2 
       SQL3 = "INSERT INTO " & Arg1 & "(TripID, ShipToZip, ArriveDelivery, Carrier, SourceWorkbook) Select Distinct [Trip ID], [Ship to Zip], [Arrive Delivery], [Carrier SCAC], SourceBook FROM TempTable WHERE ([Arrive Delivery] is NULL or len([Arrive Delivery])<2) and len([Ship To Zip])>0 and len([Trip ID])>0 ;" 
       DoCmd.RunSQL SQL3 
       DoCmd.DeleteObject acTable, "TempTable" 
       Count_Templates = Count_Templates + 1 
      End If 


     Next WS 

     OpenWorkbookED.Saved = True 
     OpenWorkbookED.Close 

     Filename = Dir() 
     Set OpenWorkbookED = Nothing 
     OpenExcel.Quit 
     Set OpenExcel = Nothing 


Loop 


'Display the end status 
TotalTime = Format((Timer - StartTime)/86400, "hh:mm:ss") 
MsgBox "Done! Error tables updated in 'Errors in DirectDeliveries Excels' group in with " & Count_Templates & " Templates " & TotalTime & " minutes", vbInformation 
Application.Echo True 
'CallFunction Delete Import Tables 
DeleteImportErrTables 

End Function 

Answer 1

合并这两种功能，所以你只打开一个实例的Excel（您OpenExcel对象）。