VBA Code Efficiency Help!

[MattH1]

Hey everyone,
I have a code that runs fine but is taking longer than I would like. I was wondering if there is any way to make this code more efficient, particularly in the formula and application of it to nearly 250,000 rows

Would ScreenUpdating really be THAT large of a change? I know I can add it to the code (and will once I know it runs smoothly while watching), but I don't think it'll take off as much time as I would like.

Function ConvertToLetter(iCol As Integer) As String
   Dim iAlpha As Integer
   Dim iRemainder As Integer
   iAlpha = Int(iCol / 27)
   iRemainder = iCol - (iAlpha * 26)
   If iAlpha > 0 Then
      ConvertToLetter = Chr(iAlpha + 64)
   End If
   If iRemainder > 0 Then
      ConvertToLetter = ConvertToLetter & Chr(iRemainder + 64)
   End If
End Function




Sub DataMerge()
Dim StartTime, Endtime As Double
StartTime = Now()

'Establish Global Variables and Workbook/Worksheet Information
Dim Worksheet As Integer
Dim TabName As String
Dim WorkBoookName As String
Dim RowCount As Long
Dim ColumnCount As Long
'Establish Workbook Name
WorkbookName = ActiveWorkbook.Name
'Establish Main Worksheet Name

'Counts the number of rows within TabName
TabName = ActiveSheet.Name
RowCount = ActiveSheet.Cells(ActiveSheet.Rows.Count, "A").End(xlUp).Row
ColumnCount = Sheets(TabName).Cells(1, Columns.Count).End(xlToLeft).Column

'Finding ID1 to use for INDEX/MATCH FORMULA
Dim FindID1 Range
With Sheets(TabName)
    Set FindID1= .Cells.Find(What:="ID1 Text")
End With

'FileIsOpen:
'Move to ALERT_DETAILS file to find column letters
Windows("Sheet2.xlsx").Activate
Dim FindID2As Range
With Sheets("ID_DETAILS")
    Set FindID2= .Cells.Find(What:="ID2 Text")
End With
Dim FindID3 As Range
With Sheets("Sheet2.xlsx)
    Set FindAlert = .Cells.Find(What:="ID3 Text")
End With
Dim FindID4 As Range
With Sheets("Sheet2.xlsx")
    Set FindID4 = .Cells.Find(What:="ID4 Text")
End With

ID1Column = ConvertToLetter(FindID1.Column)
ID2Column = ConvertToLetter(FindID2.Column)
ID3Column = ConvertToLetter(FindID3.Column)
ID4Column = ConvertToLetter(FindID4.Column)

Windows(WorkbookName).Activate
With Sheets(TabName)
    .Range("A2:A" & RowCount).Offset(, ColumnCount).Formula = "=INDEX(Sheet2.xlsx!$" & ID4Column & ":$" & ID4Column & ",MATCH($" & ID1Column & 2 & ", Sheet2.xlsx!$" & ID3Column & ":$" & ID3Column & ",0))"
    .Range("A2:A" & RowCount).Offset(, ColumnCount + 1).Formula = "=INDEX(Sheet2.xlsx!$" & ID2Column & ":$" & ID2Column & ",MATCH($" & ID1Column & 2 & ", Sheet2xlsx!$" & ID3Column & ":$" & ID3Column & ",0))"
End With

 

Endtime = Now()
MsgBox "Your code took " & (DateDiff("s", StartTime, Endtime)) & " seconds!"

EndSub

The problem is that the RowCount is 250,000 cells. And the formula takes roughly .0055 seconds per cell calculated (give or take a miniscule amount) and therefore this entire macro takes nearly 45 minutes (to an hour) to run. I was hoping to get it down somewhere near 30-35 minutes. Any tips are appreciated!

 

[MattH1]

Here's a potential solution using Dictionaries and Arrays to loop & save on processing time. I set up some dummy data on two workbooks to test and all seemed to work out. Without seeing the data, it's hard to design, but here goes nothing:

Note: Dictionaries are called using Late Binding (so no need to add "Microsoft Scripting Runtime" reference)

Hey Calc,

I absolutely love this code. It's simplistic and uses arrays and dictionaries, two things which I definitely need to get better with!

When I run the code on my data, I get this error:

"Run-time error '457'
This key is already associated with an element of this collection"

The Debug shows it coming from this line:
dID2.Add Key:=Arr(R, cID3), Item:=Arr(R, cID2)

Since I have no idea at all how this is supposed to work in terms of adding to a dictionary (still very new to it once again), any help in the right direction would be highly appreciated. I'll send you a message as well, and I appreciate you taking this much time to help with this kind of code!

Edit: I also want to add that when I went into Debug the code, it showed an interesting value for UBound(Arr,1). I previously had around 300,000 rows and decided to test this workbook using only 10,000 rows and the same amount of columns. Well, when I ran it with 10,000 rows UBound still was set to the ORIGINAL number of columns, which may (or may not) be a part of this error. Let me know if this helps at all!

 

[RoryA]

It should be faster to store the MATCH results separately and use that in both columns of INDEX formulas:

Sub DataMerge()
Dim StartTime As Double, Endtime As Double
StartTime = Now()

'Establish Global Variables and Workbook/Worksheet Information
Dim Worksheet As Integer
Dim TabName As String
Dim currentWB As Workbook
Dim otherWB As Workbook
Dim RowCount As Long
Dim ColumnCount As Long
Dim FindID1 As Range
Dim FindID2 As Range
Dim FindID3 As Range
Dim FindID4 As Range

Application.ScreenUpdating = False

'Establish Workbook
Set currentWB = ActiveWorkbook
'Establish Main Worksheet Name

'Counts the number of rows within TabName
With ActiveSheet
    RowCount = .Cells(.Rows.Count, "A").End(xlUp).Row
    ColumnCount = .Cells(1, .Columns.Count).End(xlToLeft).Column

'Finding ID1 to use for INDEX/MATCH FORMULA
    Set FindID1 = .Cells.Find(What:="ID1 Text")
End With

'FileIsOpen:
'Move to ALERT_DETAILS file to find column letters
Set otherWB = Workbooks("Sheet2.xlsx")
With otherWB
    Set FindID2 = .Sheets("ID_DETAILS").Cells.Find(What:="ID2 Text")
    With .Sheets("Sheet2.xlsx")
        Set FindID3 = .Cells.Find(What:="ID3 Text")
        Set FindID4 = .Cells.Find(What:="ID4 Text")
    End With
End With

ID1Column = FindID1.Column
ID2Column = FindID2.Column
ID3Column = FindID3.Column
ID4Column = FindID4.Column

With currentWB.ActiveSheet
    .Range("A2:A" & RowCount).Offset(, ColumnCount).FormulaR1C1 = "=MATCH(RC" & ID1Column & ", Sheet2.xlsx!C" & ID3Column & ",0)"
    .Range("A2:A" & RowCount).Offset(, ColumnCount + 1).FormulaR1C1 = "=INDEX(Sheet2.xlsx!C" & ID4Column & ",RC[-1])"
    .Range("A2:A" & RowCount).Offset(, ColumnCount + 2).FormulaR1C1 = "=INDEX(Sheet2.xlsx!C" & ID2Column & ",RC[-2])"
End With

Application.ScreenUpdating = True

Endtime = Now()
MsgBox "Your code took " & (DateDiff("s", StartTime, Endtime)) & " seconds!"

End Sub

 

[CalcSux78]

Here's an article on Dictionaries: Excel VBA Dictionary - A Complete Guide - Excel Macro Mastery

On the error, I'm curious as to why it's trying to assign a new dictionary reference to an existing Key. I'm not sure if you've used error handling much, but you could use that to show you details on why there's an error.

Example: (before the load dictionary loop, add the Red Text)

[B][COLOR=#ff0000]On Error GoTo ShowErr:[/COLOR][/B]
    For R = LBound(Arr, 1) To UBound(Arr, 1)
        If Not dID2.Exists(Arr(R, cID3)) Then:
            dID2.Add Key:=Arr(R, cID3), Item:=Arr(R, cID2)
        If Not dID4.Exists(Arr(R, cID3)) Then:
            dID4.Add Key:=Arr(R, cID3), Item:=Arr(R, cID4)
    Next R
[COLOR=#ff0000][B]On Error GoTo 0[/B][/COLOR] ' remove error handling

Then, at the bottom of the code before the "End Sub", add this:

[COLOR=#ff0000][B]Exit Sub[/B][/COLOR]
[COLOR=#ff0000][B]ShowErr:[/B][/COLOR]
[COLOR=#ff0000][B]MsgBox (R & vbLf & Arr(R, cID3) & vbLf & Arr(R, cID2))[/B][/COLOR]

 

[MattH1]

It should be faster to store the MATCH results separately and use that in both columns of INDEX formulas:

Sub DataMerge()
Dim StartTime As Double, Endtime As Double
StartTime = Now()

'Establish Global Variables and Workbook/Worksheet Information
Dim Worksheet As Integer
Dim TabName As String
Dim currentWB As Workbook
Dim otherWB As Workbook
Dim RowCount As Long
Dim ColumnCount As Long
Dim FindID1 As Range
Dim FindID2 As Range
Dim FindID3 As Range
Dim FindID4 As Range

Application.ScreenUpdating = False

'Establish Workbook
Set currentWB = ActiveWorkbook
'Establish Main Worksheet Name

'Counts the number of rows within TabName
With ActiveSheet
    RowCount = .Cells(.Rows.Count, "A").End(xlUp).Row
    ColumnCount = .Cells(1, .Columns.Count).End(xlToLeft).Column

'Finding ID1 to use for INDEX/MATCH FORMULA
    Set FindID1 = .Cells.Find(What:="ID1 Text")
End With

'FileIsOpen:
'Move to ALERT_DETAILS file to find column letters
Set otherWB = Workbooks("Sheet2.xlsx")
With otherWB
    Set FindID2 = .Sheets("ID_DETAILS").Cells.Find(What:="ID2 Text")
    With .Sheets("Sheet2.xlsx")
        Set FindID3 = .Cells.Find(What:="ID3 Text")
        Set FindID4 = .Cells.Find(What:="ID4 Text")
    End With
End With

ID1Column = FindID1.Column
ID2Column = FindID2.Column
ID3Column = FindID3.Column
ID4Column = FindID4.Column

With currentWB.ActiveSheet
    .Range("A2:A" & RowCount).Offset(, ColumnCount).FormulaR1C1 = "=MATCH(RC" & ID1Column & ", Sheet2.xlsx!C" & ID3Column & ",0))"
    .Range("A2:A" & RowCount).Offset(, ColumnCount + 1).FormulaR1C1 = "=INDEX(Sheet2.xlsx!C" & ID4Column & ",RC[-1])"
    .Range("A2:A" & RowCount).Offset(, ColumnCount + 2).FormulaR1C1 = "=INDEX(Sheet2.xlsx!C" & ID2Column & ",RC[-2])"
End With

Application.ScreenUpdating = True

Endtime = Now()
MsgBox "Your code took " & (DateDiff("s", StartTime, Endtime)) & " seconds!"

End Sub

Hey Rory thank you for this code update. I will test it now but before I run it (just to make sure I know what I'm doing here): Does this code add another column of data? If yes, I will have to get rid of it after as I don't want extra columns of data (which wouldn't be hard to do but just want to make sure).

 

[MattH1]

Here's an article on Dictionaries: Excel VBA Dictionary - A Complete Guide - Excel Macro Mastery

On the error, I'm curious as to why it's trying to assign a new dictionary reference to an existing Key. I'm not sure if you've used error handling much, but you could use that to show you details on why there's an error.

Hey Calc,
Long time no see :D
I put on an ErrorHandler and am running it right now, lets hope I can get some results and figure out what's going on. I've used one before but never to diagnose the problem and fix, just to set a MsgBox saying what kind of error it was to the user if something went wrong. I'll edit this post in a minute or two when I get the error message!

EDIT:

Hey Calc, the MsgBox simply output: "5002". Don't have ANY idea what that means :/
I made it 5000 rows, so it was two after that last row.
I just changed it to 4900 rows and ran it again and it said "4902".
No idea what's causing this to happen :/

 

[RoryA]

Yes, you end up with 3 columns of formulas on the right rather than the 2 you had before.

 

[MattH1]

Yes, you end up with 3 columns of formulas on the right rather than the 2 you had before.

Hey Rory, running your code with 3 columns gave me "Application-defined or object-defined error", so something isn't being defined right. I don't know why though, I've declared every variable I'm using...

 

[RoryA]

There was a typo in the MATCH formula which I've now corrected in the original post so can you try it again?

 

[MattH1]

There was a typo in the MATCH formula which I've now corrected in the original post so can you try it again?

So the code fully ran through. The problem lies now in the actual formula that you are using, which gave out this result:

"=MATCH(RCC, Sheet2.xlsx!CA,0)" in the first column.

It should look more like this =MATCH(C2,Sheet2.xlsx!A:A,0)
Any idea how to go about fixing it? I see that you're using RC[] coding, but ID1Column, ID2Column, etc... and these are letters, not numbers. Those variables are the result of my function that changes Column 3 to Column C.

 

[RoryA]

but ID1Column, ID2Column, etc... and these are letters, not numbers.

Not in the code I posted they aren't since I removed the calls to those functions.