VBA: Speed up macro (for large file)

M

Mange

New Member
Joined
Sep 8, 2016
Messages
20


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.

Code: 
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!!



<tbody>
</tbody>
 
Sort by date Sort by votes

Excel Facts

Last used cell?
Press Ctrl+End to move to what Excel thinks is the last used cell.
Hope it's now matter of seconds:
Rich (BB code): 
Sub Compare()
 
  'Sheets
  Dim wsDec As Worksheet
  Dim wsJun As Worksheet
  Dim wsPP As Worksheet
  Dim wsPA As Worksheet
  Dim wsAP As Worksheet
 
  'Last rows
  Dim lrDec As Long
  Dim lrJun As Long
  Dim lrPP As Long
  Dim lrPA As Long
  Dim lrAP As Long
 
  'Last columns (approx 236)
  Dim lcDec As Long
  Dim lcJun As Long
 
  'Dictionary
  Dim dicDec As Object
  Dim dicJun As Object
 
  'Utility variables
  Dim i As Long, j As Long
  Dim s As String
  Dim a(), b(), v
 
  'Get worksheets
  Set wsDec = Worksheets("DataDec")
  Set wsJun = Worksheets("DataJune")
  Set wsPP = Worksheets("PresPres")
  Set wsPA = Worksheets("PresAbs")
  Set wsAP = Worksheets("AbsPres")
 
  ' Fill the titles (at least for the correct debugging)
  If Len(wsJun.Cells(1)) Then
    a() = wsJun.UsedRange.Rows(1).Value
    wsDec.Cells().Resize(1, UBound(a, 2)).Value = a()
    wsPP.Cells().Resize(1, UBound(a, 2)).Value = a()
    wsPA.Cells().Resize(1, UBound(a, 2)).Value = a()
    wsAP.Cells().Resize(1, UBound(a, 2)).Value = a()
  End If
 
  'Define the last row of the different sheets
  lrDec = wsDec.Cells(wsDec.Rows.Count, 2).End(xlUp).Row
  lrJun = wsJun.Cells(wsJun.Rows.Count, 2).End(xlUp).Row
  lrPP = wsPP.Cells(wsPP.Rows.Count, 2).End(xlUp).Row
  lrPA = wsPA.Cells(wsPA.Rows.Count, 2).End(xlUp).Row
  lrAP = wsAP.Cells(wsAP.Rows.Count, 2).End(xlUp).Row
 
  'Define the last column of Dec an Jun sheets
  lcDec = wsDec.Cells(1, wsDec.Columns.Count).End(xlToLeft).Column
  lcJun = wsJun.Cells(1, wsJun.Columns.Count).End(xlToLeft).Column
 
  'Stop screen from updating to speed things up
  Application.ScreenUpdating = False
  Application.EnableEvents = False
 
  ' Create dictionary of Jun
  Set dicJun = CreateObject("Scripting.Dictionary")
  dicJun.CompareMode = 1
  a() = wsJun.Range("B1:B" & IIf(lrJun > 1, lrJun, 2)).Value
  With dicJun
    For i = 2 To lrJun
      s = Trim(a(i, 1))
      If Len(s) Then
        .Item(s) = i
      End If
    Next
  End With
 
  ' Create dictionary of Dec
  Set dicDec = CreateObject("Scripting.Dictionary")
  dicDec.CompareMode = 1
  a() = wsDec.Range("B1:B" & IIf(lrDec > 1, lrDec, 2)).Value
  ReDim b(1 To lrDec, 1 To 1)
  b(1, 1) = "TmpHdr"
  With dicDec
    For i = 2 To lrDec
      s = Trim(a(i, 1))
      If Len(s) Then
        .Item(s) = i
        If dicJun.Exists(s) Then
          'Mark the common items in b()
          b(i, 1) = 1
          j = j + 1
        End If
      End If
    Next
  End With
 
  'Copy common data of wsDec to wsPP and the unique data - to wsAP
  If j Or dicDec.Count Then
    With wsDec.Range("A1", wsDec.Cells(lrDec, lcDec + 2))
      .Columns(lcDec + 2).Value = b()
      ' Save the initial order of rows
      For i = 1 To lrDec
        b(i, 1) = i
      Next
      .Columns(lcDec + 1).Value = b()
      'Sort by values of b()
      .Sort Key1:=.Cells(1, lcDec + 2), Order1:=xlAscending, Header:=xlYes
      'Copy common data to wsPP
      If j Then
        'Copy common data to wsPP
        .Resize(j, lcDec).Offset(1).Copy wsPP.Cells(lrPP + 1, 1)
      End If
      'Copy unique data to wsAP
      If dicDec.Count Then
        .Resize(lrDec - j - 1, lcDec).Offset(j + 1).Copy wsAP.Cells(lrAP + 1, 1)
      End If
      ' Restore the sheet view
      .Sort Key1:=.Cells(1, lcDec + 1), Order1:=xlAscending, Header:=xlYes
      .Resize(, 2).Offset(, lcDec).ClearContents
    End With
   
    'Restore used range of wsDec and clear a()
    With wsDec.UsedRange: End With
    ReDim a(0)
   
    ' Copy data to wsAP
    ReDim b(1 To lrJun, 1 To 1)
    With dicJun
      j = 0
      For Each v In .Keys
        If Not dicDec.Exists(v) Then
          j = j + 1
          b(.Item(v), 1) = 1
        End If
      Next
    End With
    If j Then
      With wsJun.Range("A1", wsJun.Cells(lrJun, lcJun + 2))
        .Columns(lcJun + 2).Value = b()
        ' Save the initial order of rows
        For i = 1 To lrJun
          b(i, 1) = i
        Next
        .Columns(lcJun + 1).Value = b()
        'Sort by values of b()
        .Sort Key1:=.Cells(1, lcJun + 2), Order1:=xlAscending, Header:=xlYes
        'Copy unique data to wsPA
        .Resize(j, lcJun).Offset(1).Copy wsPA.Cells(lrPA + 1, 1)
         ' Restore the sheet wsJun
        .Sort Key1:=.Cells(1, lcJun + 1), Order1:=xlAscending, Header:=xlYes
        .Resize(, 2).Offset(, lcJun).ClearContents
      End With
    End If
   
    'Restore used range of wsJun
    With wsJun.UsedRange: End With
   
  End If
 
  'Release the memory of object variables
  Set dicDec = Nothing
  Set dicJun = Nothing
 
  'Re-enable screen updating.
  Application.ScreenUpdating = True
  Application.EnableEvents = True
 
End Sub
 
Last edited:
Upvote 0
Thank you so much! It takes now about 20 seconds, which is a massive improvement! Could you explain briefly the logic behind the code, or the changes you made in comparison with the code of wideboydixon, because you both work with dictionaries?

A big thanks to wideboydixon as well for your help!
 
Upvote 0
Mange said:
Thank you so much! It takes now about 20 seconds, which is a massive improvement! Could you explain briefly the logic behind the code, or the changes you made in comparison with the code of wideboydixon, because you both work with dictionaries?

A big thanks to wideboydixon as well for your help!
Click to expand...
You are welcome!

So, here is a short description of the issue and the method used for speeding up the code.

Usually the using of the dictionaries saves time dramatically by excluding an extra looping and via fast comparisons.
But the major factor of delay in this case was in massive iterations between VBA and Excel object models.
That slow process can be fastened by copying data to VBA arrays, calculating all staff in VBA, preparing the resulting data in arrays, and only after that copying the data of arrays to the sheet.

The problem was in need of line by line copying rows as the result of comparison which exclude the described benefits of using arrays.
In my code flags (Empty or 1) of comparison for each source sheet are stored in aux array b() without any iterations between VBA and Excel. At the end of comparison the values of array b() are copied to the right side of the source data into extra column. After that the source data with that extra column are sorted (it's fast in Excel) by flags, thus the rows with flags = 1 become on the top of the table in a single area. Then that source rows with flag=1 are copied to the destination sheet at one step. The other rows with flag=Empty, which are in another single area, are copied to another destination sheet also via one step.
So only a few iterations between VBA and Excel happen which saves a lot of operating time as we can see.

To restore original order of the sorted data rows, one more aux column is used on the right side of the data range with the original indexes of rows.
Both aux columns are cleaned at the end.
 
Last edited:
Upvote 0
Very good. I never realised manipulating ranges etc. in VBA was so slow and I like the ingenious use of your b() array to create a couple of helper columns for sorting :)

WBD
 
Upvote 0
Hi WBD,
Nice style of your code! I've stolen your declarations to not lose the logic :)
It's good for me too to find and learn each time something new from here
 
Upvote 0
Last post on this for now. I took ZVI's excellent code and adapted, commented and made the variable names more friendly. On your test sheet (without the extra columns) this code executes in around 4 seconds!

Code: 
Option Explicit
Sub Compare()

'Sheets
Dim wsDec As Worksheet
Dim wsJun As Worksheet
Dim wsPP As Worksheet
Dim wsPA As Worksheet
Dim wsAP As Worksheet

'Last rows
Dim lrDec As Long
Dim lrJun As Long
Dim lrPP As Long
Dim lrPA As Long
Dim lrAP As Long

'Last coluns
Dim lcDec As Long
Dim lcJun As Long

'Dictionary
Dim dicJun As Object
Dim dicDec As Object

'Utility variables
Dim thisRow As Long
Dim fileNum As String
Dim fileNums()
Dim matchDec()
Dim matchJun()
Dim matchCount As Long

'Get worksheets
Set wsDec = Worksheets("DataDec")
Set wsJun = Worksheets("DataJune")
Set wsPP = Worksheets("PresPres")
Set wsPA = Worksheets("PresAbs")
Set wsAP = Worksheets("AbsPres")

'Copy headers
wsDec.Rows(1).Copy wsPP.Cells(1, 1)
wsDec.Rows(1).Copy wsPA.Cells(1, 1)
wsDec.Rows(1).Copy wsAP.Cells(1, 1)

'Define the last row of the different sheets
lrDec = wsDec.Cells(wsDec.Rows.Count, 2).End(xlUp).Row
lrJun = wsJun.Cells(wsJun.Rows.Count, 2).End(xlUp).Row
lrPP = wsPP.Cells(wsPP.Rows.Count, 2).End(xlUp).Row
lrPA = wsPA.Cells(wsPA.Rows.Count, 2).End(xlUp).Row
lrAP = wsAP.Cells(wsAP.Rows.Count, 2).End(xlUp).Row

'Define last columns
lcDec = wsDec.Cells(1, wsDec.Columns.Count).End(xlToLeft).Column
lcJun = wsJun.Cells(1, wsJun.Columns.Count).End(xlToLeft).Column

' Timer
Dim startTime As Single
startTime = Timer

'Get list of file numbers for June
Set dicJun = CreateObject("Scripting.Dictionary")
fileNums = wsJun.Range(wsJun.Cells(1, 2), wsJun.Cells(lrJun, 2)).Value

'Keep a track of matches and row numbers
ReDim matchJun(1 To lrJun, 1 To 2)
matchJun(1, 1) = "TempHeader1"
matchJun(1, 2) = "TempHeader2"

'Process all the rows in June
For thisRow = 2 To lrJun
    fileNum = Trim(wsJun.Cells(thisRow, 2).Value)
    If Len(fileNum) Then
        'Assume no match for now
        dicJun(fileNum) = thisRow
        matchJun(thisRow, 1) = thisRow
        matchJun(thisRow, 2) = 1
    End If
Next thisRow

'Get list of file numbers for December
Set dicDec = CreateObject("Scripting.Dictionary")
fileNums = wsDec.Range(wsDec.Cells(1, 2), wsDec.Cells(lrDec, 2)).Value

'Keep a track of matches and row numbers
ReDim matchDec(1 To lrDec, 1 To 2)
matchDec(1, 1) = "TempHeader1"
matchDec(1, 2) = "TempHeader2"
matchCount = 0

'Process all the rows in December
For thisRow = 2 To lrDec
    fileNum = Trim(wsDec.Cells(thisRow, 2).Value)
    If Len(fileNum) Then
        dicDec(fileNum) = thisRow
        matchDec(thisRow, 1) = thisRow
        
        'Check if we already have this in the June list
        If dicJun.exists(fileNum) Then
            'Record the match
            matchDec(thisRow, 2) = 0
            matchJun(dicJun(fileNum), 2) = 0
            matchCount = matchCount + 1
        Else
            'No match
            matchDec(thisRow, 2) = 1
        End If
    End If
Next thisRow

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

'Process December sheet
With wsDec.Range(wsDec.Cells(1, 1), wsDec.Cells(lrDec, lcDec + 2))
    .Resize(, 2).Offset(, lcDec).Value = matchDec
    .Sort Key1:=.Cells(1, lcDec + 2), Order1:=xlAscending, Header:=xlYes
    If matchCount > 0 Then .Resize(matchCount, lcDec).Offset(1).Copy wsPP.Cells(lrPP + 1, 1)
    If dicDec.Count > 0 Then .Resize(lrDec - matchCount - 1, lcDec).Offset(matchCount + 1).Copy wsPA.Cells(lrPA + 1, 1)
    .Sort Key1:=.Cells(1, lcDec + 1), Order1:=xlAscending, Header:=xlYes
    .Resize(, 2).Offset(, lcDec).ClearContents
End With

'Process June sheet
With wsJun.Range(wsJun.Cells(1, 1), wsJun.Cells(lrJun, lcJun + 2))
    .Resize(, 2).Offset(, lcJun).Value = matchJun
    .Sort Key1:=.Cells(1, lcJun + 2), Order1:=xlAscending, Header:=xlYes
    If dicJun.Count > 0 Then .Resize(lrJun - matchCount - 1, lcJun).Offset(matchCount + 1).Copy wsAP.Cells(lrAP + 1, 1)
    .Sort Key1:=.Cells(1, lcJun + 1), Order1:=xlAscending, Header:=xlYes
    .Resize(, 2).Offset(, lcJun).ClearContents
End With

'Re-enable screen updating.
Application.ScreenUpdating = True
Application.EnableEvents = True

' Report
Debug.Print "Time taken : " & Timer - startTime

End Sub
 
Upvote 0
You must log in or register to reply here.

Similar threads

C
  • Solved
Need Help VBA
2
Replies
10
Views
314
Trebor76
T
D
  • Question
Generating Reports in Word Using Data in Excel
Replies
0
Views
119
davidd30528
D
J
  • Question
Search folder for value and list left/right value
Replies
2
Views
178
JJCam
J
M
  • Question
Copy File Names to Destination File
Replies
2
Views
256
metalscuba
M
T
  • Question
VBA Stuck Sanitising Several Sheets
Replies
2
Views
147
Tarkemelion
T

Forum statistics

Threads
1,221,418
Messages
6,159,795
Members
451,589
Latest member
Harold14

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top