Hi Experts,
I wrote below code in a form for my team. It's a simple 'open file - copy - paste' exercise but for some reason a bunch of users are getting these random Automation Errors. I believe it happens when two big files are opened.
Some users fix this after a restart and I had one user to reinstall his Excel to 64-bit and it also fixed the issues, so I suspect the memory gets overloaded by the macro?
I'm wondering what part of the code might be so heavy that this happens for some and not for others.
Thanks for your inputs
I wrote below code in a form for my team. It's a simple 'open file - copy - paste' exercise but for some reason a bunch of users are getting these random Automation Errors. I believe it happens when two big files are opened.
Some users fix this after a restart and I had one user to reinstall his Excel to 64-bit and it also fixed the issues, so I suspect the memory gets overloaded by the macro?
I'm wondering what part of the code might be so heavy that this happens for some and not for others.
Thanks for your inputs
Code:
Sub MatchRecs()Dim i, x As Long
Dim Rec, Partnerec As Workbook
Dim CoCd, lastrow As String
'open my MainRec
'loop through open workbooks to see if the rec is already opened, if yes close it
For Each Workbook In Workbooks
If Workbook.Name = "Intercompany Recs " & Country.Value & " # " & FileBoxItem Then
Workbooks("Intercompany Recs " & Country.Value & " # " & FileBoxItem).Close True
Exit For
End If
Next Workbook
Set Rec = Workbooks.Open(filename:=path & FYBox.Value & "\" & PeriodBox.Value & "\Intercompany Recs " & Country.Value & " # " & FileBoxItem, UpdateLinks:=False)
CoCd = Rec.Sheets("Data").Range("E2").Value
'loop through all partners
For i = 1 To Rec.Sheets("One Look").PivotTables("OneLook").PivotFields("Tr.Prt").PivotItems.Count
'lookup partner country folder name
Rec.Sheets("One Look").Cells(i + 9, 50).Value = "=IFNA(VLOOKUP(""" & Rec.Sheets("One Look").Cells(i + 9, 1).Value & """, '" & Left(MasterPath, Len(MasterPath) - 15) & "[MasterFile.xlsx]Master'!$A:$H, 8, 0),0)"
'check if there is already data in the pivot and if partner rec exists and it's not the same file as Rec
If Rec.Sheets("One Look").Range("J" & i + 9) & Rec.Sheets("One Look").Range("K" & i + 9) & Rec.Sheets("One Look").Range("L" & i + 9) & Rec.Sheets("One Look").Range("M" & i + 9) & Rec.Sheets("One Look").Range("N" & i + 9) & Rec.Sheets("One Look").Range("O" & i + 9) = "" _
And Dir(IntercoFolder & Rec.Sheets("One Look").Cells(i + 9, 50).Value & " interco\7 RECONCIL\" & FYBox.Value & "\" & PeriodBox.Value & "\Intercompany Recs " & Rec.Sheets("One Look").Cells(i + 9, 50).Value & " # " & Rec.Sheets("One Look").Cells(i + 9, 1).Value & ".xlsb") <> "" _
And Dir(IntercoFolder & Rec.Sheets("One Look").Cells(i + 9, 50).Value & " interco\7 RECONCIL\" & FYBox.Value & "\" & PeriodBox.Value & "\Intercompany Recs " & Rec.Sheets("One Look").Cells(i + 9, 50).Value & " # " & Rec.Sheets("One Look").Cells(i + 9, 1).Value & ".xlsb") <> Rec.Name Then
'open partner rec
Set Partnerec = Workbooks.Open(filename:=IntercoFolder & Rec.Sheets("One Look").Cells(i + 9, 50).Value & " interco\7 RECONCIL\" & FYBox.Value & "\" & PeriodBox.Value & "\Intercompany Recs " & Rec.Sheets("One Look").Cells(i + 9, 50).Value & " # " & Rec.Sheets("One Look").Cells(i + 9, 1).Value & ".xlsb", UpdateLinks:=False, ReadOnly:=True)
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual
'if partner rec is already matched, remove the data to avoid duplication
With Partnerec.Sheets("Data").ListObjects("Data")
.Range.AutoFilter field:=1, Criteria1:="Partner AP", Operator:=xlOr, Criteria2:="Partner AR"
If .ListColumns(1).Range.SpecialCells(xlCellTypeVisible).Count > 1 Then .DataBodyRange.SpecialCells(xlCellTypeVisible).Delete
.Range.AutoFilter field:=1, Criteria1:="Partner AP LOAN", Operator:=xlOr, Criteria2:="Partner AR LOAN"
If .ListColumns(1).Range.SpecialCells(xlCellTypeVisible).Count > 1 Then .DataBodyRange.SpecialCells(xlCellTypeVisible).Delete
.AutoFilter.ShowAllData
'amend AP/AR to fit partner match format and copy relevant columns
.Range.AutoFilter field:=1, Criteria1:="AP"
If .ListColumns(1).Range.SpecialCells(xlCellTypeVisible).Count > 1 Then .ListColumns(1).DataBodyRange.SpecialCells(xlCellTypeVisible).Value = "Partner AP"
.Range.AutoFilter field:=1, Criteria1:="AR"
If .ListColumns(1).Range.SpecialCells(xlCellTypeVisible).Count > 1 Then .ListColumns(1).DataBodyRange.SpecialCells(xlCellTypeVisible).Value = "Partner AR"
.Range.AutoFilter field:=1, Criteria1:="AP LOAN"
If .ListColumns(1).Range.SpecialCells(xlCellTypeVisible).Count > 1 Then .ListColumns(1).DataBodyRange.SpecialCells(xlCellTypeVisible).Value = "Partner AP LOAN"
.Range.AutoFilter field:=1, Criteria1:="AR LOAN"
If .ListColumns(1).Range.SpecialCells(xlCellTypeVisible).Count > 1 Then .ListColumns(1).DataBodyRange.SpecialCells(xlCellTypeVisible).Value = "Partner AR LOAN"
.AutoFilter.ShowAllData
.ListColumns(5).Range.Cut
.ListColumns(3).Range.Insert Shift:=xlToRight
.ListColumns(4).Range.Cut
.ListColumns(6).Range.Insert Shift:=xlToRight
.Range.AutoFilter field:=5, Criteria1:=CoCd
If .ListColumns(5).Range.SpecialCells(xlCellTypeVisible).Count > 1 Then
Union(.ListColumns(3).DataBodyRange.SpecialCells(xlCellTypeVisible), _
.ListColumns(4).DataBodyRange.SpecialCells(xlCellTypeVisible), _
.ListColumns(5).DataBodyRange.SpecialCells(xlCellTypeVisible), _
.ListColumns(6).DataBodyRange.SpecialCells(xlCellTypeVisible), _
.ListColumns(7).DataBodyRange.SpecialCells(xlCellTypeVisible), _
.ListColumns(8).DataBodyRange.SpecialCells(xlCellTypeVisible), _
.ListColumns(9).DataBodyRange.SpecialCells(xlCellTypeVisible), _
.ListColumns(10).DataBodyRange.SpecialCells(xlCellTypeVisible), _
.ListColumns(11).DataBodyRange.SpecialCells(xlCellTypeVisible), _
.ListColumns(12).DataBodyRange.SpecialCells(xlCellTypeVisible), _
.ListColumns(13).DataBodyRange.SpecialCells(xlCellTypeVisible)).Copy
'paste data to mainrec and close partner without saving
lastrow = Rec.Sheets("Data").Range("E1").End(xlDown).Row + 1
Rec.Sheets("Data").Range("C" & lastrow).PasteSpecial xlPasteValues
.ListColumns(1).DataBodyRange.SpecialCells(xlCellTypeVisible).Copy
Rec.Sheets("Data").Range("A" & lastrow).PasteSpecial xlPasteValues
End If
End With
Partnerec.Close False
End If
Next i
'remove partner folder names and save
Rec.Sheets("One Look").Columns(50).ClearContents
Application.Calculation = xlCalculationAutomatic
Rec.RefreshAll
Application.DisplayAlerts = True
Rec.Close True
End Sub