VBA: Speed up macro (for large file)

[Mange]

<tbody>
[TD="class: votecell"]

[/TD]
[TD="class: postcell"]I wrote a macro that compares the columns B, which contains file numbers, in two worksheets. There are three possibilities: the file number exists in both columns, the file number exists only in the first column and the file number exists only in the second column. If e.g. the file number exists in both columns, the macro should copy/paste the entire row to another sheet. Same for the other two scenario's.
My code work perfect for a small file (around 500 rows, 236 columns), but for the large files it doesn't work. It takes way too long, and at the end it just crashes. I already tried the usual tricks to speed up the macro.

Option Explicit
Sub CopyPasteWorksheets()
Dim wbDec As Workbook, wbJune As Workbook, wbAnalysis As Workbook
Dim wsDec As Worksheet, wsJune As Worksheet
Dim PresPres As Worksheet, PresAbs As Worksheet, AbsPres As Worksheet
'Stop screen from updating to speed things up
Application.ScreenUpdating = False
Application.EnableEvents = False
'Add 3 new worksheets. They each represent a different category, namely the one with already existing insurances, one with new insurances
'and one with the insurances that are closed due to mortality, lapse or maturity. Add two (temporary) worksheets to paste the databases.
Worksheets.Add().Name = "PresPres"
Worksheets.Add().Name = "PresAbs"
Worksheets.Add().Name = "AbsPres"
Worksheets.Add().Name = "DataDec"
Worksheets.Add().Name = "DataJune"
'Define the active workbook
Set wbAnalysis = ThisWorkbook
'Define the first database. Copy/paste the sheet and close them afterwards.
Set wbDec = Workbooks.Open(Filename:="F:\Risk_Management_2\Embedded_Value\2015\20151231\Data\DLL\Master Scala\Extract.xlsx")
wbDec.Sheets("SCALA").Range("A1").CurrentRegion.Copy
wbAnalysis.Sheets("DataDec").Range("A1").PasteSpecial xlPasteValues
wbDec.Close
'We have to do the same for the other database. We cannot do it at the same time, because both files have the same name,
'and can't be opened at the same time.
Set wbJune = Workbooks.Open(Filename:="F:\Risk_Management_2\Embedded_Value\2016\20160630\Data\DLL\Master Scala\extract.xlsx")
wbJune.Sheets("SCALA").Range("A1").CurrentRegion.Copy
wbAnalysis.Sheets("DataJune").Range("A1").PasteSpecial xlPasteValues
    
wbJune.Close
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
Sub Compare()
Dim DataDec As Worksheet, DataJune As Worksheet
Dim lastRowDec As Long
Dim lastRowJune As Long
Dim lastRowPresAbs As Long
Dim lastRowPresPres As Long
Dim lastRowAbsPres As Long
Dim foundTrue As Boolean
Dim i As Long, j As Long, k As Long, l As Long
'Define the last row of the different sheets
lastRowDec = Sheets("DataDec").Cells(Sheets("DataDec").Rows.Count, "B").End(xlUp).Row
lastRowJune = Sheets("DataJune").Cells(Sheets("DataJune").Rows.Count, "B").End(xlUp).Row
lastRowPresAbs = Sheets("PresAbs").Cells(Sheets("PresAbs").Rows.Count, "B").End(xlUp).Row
lastRowPresPres = Sheets("PresPres").Cells(Sheets("PresPres").Rows.Count, "B").End(xlUp).Row
lastRowAbsPres = Sheets("AbsPres").Cells(Sheets("AbsPres").Rows.Count, "B").End(xlUp).Row
'Compare the file numbers in column B of both sheets. If they are the same, copy/paste the entire row to sheet PresPres,
'if they are not, copy/paste the entire row to sheet PresAbs.
For i = 1 To lastRowDec
foundTrue = False
For j = 1 To lastRowJune
    If Sheets("DataDec").Cells(i, 1).Value = Sheets("DataJune").Cells(j, 1).Value Then
        foundTrue = True
        Sheets("PresPres").Rows(lastRowPresPres + 1) = Sheets("DataDec").Rows(i)
        lastRowPresPres = lastRowPresPres + 1
        Exit For
    End If
Next j
If Not foundTrue Then
    Sheets("DataDec").Rows(i).Copy Destination:= _
    Sheets("PresAbs").Rows(lastRowPresAbs + 1)
    lastRowPresAbs = lastRowPresAbs + 1
End If
Next i

'Look if there are file numbers that are only present in June's database. If so, copy/paste entire row to sheet AbsPres.
For k = 1 To lastRowJune
foundTrue = False
For l = 1 To lastRowDec
    If Sheets("DataJune").Cells(k, 1).Value = Sheets("DataDec").Cells(l, 1).Value Then
        foundTrue = True
        Exit For
    End If
    
Next l
If Not foundTrue Then
    Sheets("DataJune").Rows(k).Copy Destination:= _
    Sheets("AbsPres").Rows(lastRowAbsPres + 1)
    lastRowAbsPres = lastRowAbsPres + 1
End If
Next k
'Stop screen from updating to speed things up.
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub

I've added some comments to explain what I'm trying to do. I'm relatively new to VBA so I believe I'm not coding very efficient.
Could someone have a look and try to make it work?
Thanks!!


[/TD]

</tbody>

 

[wideboydixon]

I made some changes to your Compare() Sub which might help by using dictionaries:

Sub Compare()

Dim DataDec As Worksheet, DataJune As Worksheet
Dim lastRowDec As Long
Dim lastRowJune As Long
Dim lastRowPresAbs As Long
Dim lastRowPresPres As Long
Dim lastRowAbsPres As Long
Dim foundTrue As Boolean
Dim i As Long, j As Long, k As Long, l As Long
Dim JunData As Object
Dim DecData As Object
Dim fileNum As Variant

'Define the last row of the different sheets
lastRowDec = Sheets("DataDec").Cells(Sheets("DataDec").Rows.Count, "B").End(xlUp).Row
lastRowJune = Sheets("DataJune").Cells(Sheets("DataJune").Rows.Count, "B").End(xlUp).Row
lastRowPresAbs = Sheets("PresAbs").Cells(Sheets("PresAbs").Rows.Count, "B").End(xlUp).Row
lastRowPresPres = Sheets("PresPres").Cells(Sheets("PresPres").Rows.Count, "B").End(xlUp).Row
lastRowAbsPres = Sheets("AbsPres").Cells(Sheets("AbsPres").Rows.Count, "B").End(xlUp).Row

'Create the dictionaries of file numbers for June
Set JunData = CreateObject("Scripting.Dictionary")
For i = 1 To lastRowJune
    JunData(Sheets("DataJune").Cells(i, 2).Value) = i
Next i

' Create the dictionary of file numbers for December
Set DecData = CreateObject("Scripting.Dictionary")
For i = 1 To lastRowDec
    DecData(Sheets("DataDec").Cells(i, 2).Value) = i
Next i

For Each fileNum In DecData.Keys
    i = DecData(fileNum)
    If JunData.Exists(fileNum) Then
        lastRowPresPres = lastRowPresPres + 1
        Sheets("PresPres").Rows(lastRowPresPres).Value = Sheets("DataDec").Rows(i).Value
    Else
        lastRowPresAbs = lastRowPresAbs + 1
        Sheets("PresAbs").Rows(lastRowPresAbs).Value = Sheets("DataDec").Rows(i).Value
    End If
Next fileNum

For Each fileNum In JunData.Keys
    If Not DecData.Exists(fileNum) Then
        lastRowAbsPres = lastRowAbsPres + 1
        Sheets("AbsPres").Rows(lastRowAbsPres).Value = Sheets("DataJune").Rows(JunData(fileNum)).Value
    End If
Next fileNum

'Stop screen from updating to speed things up.
Application.ScreenUpdating = True
Application.EnableEvents = True

End Sub

Note that your original code was comparing using column A but your description say it should use column B. Change the highlighted values as appropriate. I tested with a small data set but you'll need to see if it works better for you this way.

WBD

 

[Mange]

Thanks for your answer. There's indeed an error in the original code. It has to be .Cells(i, 2).

If I use your code, I get the same error as with mine:
There isn't enough memory to complete this action.
Try using less data or closing other applications.
To increase memory availability, consider:
- Using a 64-bit version of Microsoft Excel.
- Adding memory to your device

 

[wideboydixon]

Well, that's disappointing. How many rows are on the June and December sheets? The other alternative is to code it up to use the MATCH worksheet function.

WBD

 

[Mange]

There are about 90 000 rows on those sheets.

 

[wideboydixon]

Then perhaps try using MATCH:

Sub Compare()

Dim lastRowDec As Long
Dim lastRowJune As Long
Dim lastRowPresAbs As Long
Dim lastRowPresPres As Long
Dim lastRowAbsPres As Long
Dim i As Long
Dim JunData As Range
Dim DecData As Range
Dim foundRow As Double

'Define the last row of the different sheets
lastRowDec = Sheets("DataDec").Cells(Sheets("DataDec").Rows.Count, "B").End(xlUp).Row
lastRowJune = Sheets("DataJune").Cells(Sheets("DataJune").Rows.Count, "B").End(xlUp).Row
lastRowPresAbs = Sheets("PresAbs").Cells(Sheets("PresAbs").Rows.Count, "B").End(xlUp).Row
lastRowPresPres = Sheets("PresPres").Cells(Sheets("PresPres").Rows.Count, "B").End(xlUp).Row
lastRowAbsPres = Sheets("AbsPres").Cells(Sheets("AbsPres").Rows.Count, "B").End(xlUp).Row

'Set the source range data
Set JunData = Sheets("DataJune").Range("B1:B" & lastRowJune)
Set DecData = Sheets("DataDec").Range("B1:B" & lastRowDec)

On Error Resume Next

'Create the dictionaries of file numbers for June
For i = 1 To lastRowDec
    Err.Clear
    foundRow = WorksheetFunction.Match(Sheets("DataDec").Cells(i, 2).Value, JunData, 0)
    If Err.Number > 0 Then
        lastRowPresAbs = lastRowPresAbs + 1
        Sheets("PresAbs").Rows(lastRowPresAbs).Value = Sheets("DataDec").Rows(i).Value
    Else
        lastRowPresPres = lastRowPresPres + 1
        Sheets("PresPres").Rows(lastRowPresPres).Value = Sheets("DataDec").Rows(i).Value
    End If
Next i

For i = 1 To lastRowJune
    Err.Clear
    foundRow = WorksheetFunction.Match(Sheets("DataJune").Cells(i, 2).Value, DecData, 0)
    If Err.Number > 0 Then
        lastRowAbsPres = lastRowAbsPres + 1
        Sheets("AbsPres").Rows(lastRowAbsPres).Value = Sheets("DataJune").Rows(i).Value
    End If
Next i

'Stop screen from updating to speed things up.
Application.ScreenUpdating = True
Application.EnableEvents = True

End Sub

WBD

 

[wideboydixon]

There are about 90 000 rows on those sheets.

So you're running about 16 billion comparisons. Ouch. The code above should only run 180,000 loops which hopefully is in the region of 90,000 x faster

WBD

 

[Mange]

Even your code with 180 000 loops doesn't work.. It will maybe work faster if we do a SORT in column B first?

 

[Mange]

For you information, your first solution took, in my testfile (700 rows), about 8 seconds. The last solution took 6.62 seconds. But still the error message on the large file.

 

[wideboydixon]

Same error message? I don't see why it would run out of memory; it's not doing anything memory intensive. I'm a bit stuck now unless you want to share the file and I can take a look.

WBD