Running two VBA codes on same Excel breaks - ms-access

Question

I am using VBA in Access to modify a excel sheet using Macro 1 and input it in a table using Macro 2. When I run both of these consecutively, my system gets stuck in a loop, but works fine if I restart the Microsoft access application after running one Macro and run Macro 2. Also at times, the excel file on which I am running my code gets a pop-up box to enable read/write access.. Can someone help me with it?
Macro1
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
Macro 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

Merge the two functions so you only open one instance (your OpenExcel object) of Excel.