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!

 

[mumps]

You could try this code to see if it makes much of a difference:

Application.ScreenUpdating = False
Application.Calculation = xlManual
'your code here
Application.Calculation = xlAutomatic
Application.ScreenUpdating = True

 

[mikerickson]

I'm curious about the ConvertToLetter function.

Shouldn't both of the constants be 26

 iAlpha = Int(iCol / 27)
   iRemainder = iCol - (iAlpha * 26)

Also, is this possible simplification

ConvertToLetter = Split(Columns(iCol).Address(False,False,xlA1), ":")(0)

 

[MattH1]

You could try this code to see if it makes much of a difference:

Application.ScreenUpdating = False
Application.Calculation = xlManual
'your code here
Application.Calculation = xlAutomatic
Application.ScreenUpdating = True

I already have the entire spreadsheet set to Manual, do you think that will truly make much of a difference? I'll run it and let you know when it's done (Going to run a small sample of it, only 5-10,000 cells to test how much faster/slower it may be.

 

[MattH1]

I'm curious about the ConvertToLetter function.

Shouldn't both of the constants be 26

 iAlpha = Int(iCol / 27)
   iRemainder = iCol - (iAlpha * 26)

Also, is this possible simplification

ConvertToLetter = Split(Columns(iCol).Address(False,False,xlA1), ":")(0)

I used the ConvertToLetter function that Microsoft provided here:https://support.microsoft.com/en-us/kb/833402
I figured that would be the most efficient way to do it, though I can 100% be wrong. I guess I'll run a test with this as well after I finish running the edit that mumps suggested.

 

[CalcSux78]

I think your code is taking so long because it has to do 500,000 Index/Match calculations when running. Will the data in your table be changing after the code runs?

 

[MattH1]

I think your code is taking so long because it has to do 500,000 Index/Match calculations when running. Will the data in your table be changing after the code runs?

I understand that the code should take some time given that it's running 500,000 Index/Match calculations (which I believe to be faster than VLOOKUP, though I can be wrong. It seems everyone has their own opinion.)

However, when I run it on my own by just typing in the formula and dragging it down it only seemed to take approximately 40 minutes, so I'm curious if something is just clunky in my processing (possibly with the ConvertToLetter and re-referencing of it in the formula even though I redefined the variable so it wouldn't recalculate ConvertToLetter each time).

For all I know this may be the most efficient but ANY time taken off this program would be SUPER helpful, it's quite long as is (for obvious reasons).


EDIT: This program will run once and then use these cells in another macro, so they won't be changing after the program runs. Just used to copy/paste (values) to another document.

 

[MattH1]

Mumps it ran at the same speed, maybe a minute faster but may have been that I had more stuff closed at the time (I closed Internet Explorer to run it otherwise I think it would've been the same.)

 

[mumps]

Sorry it didn't make such a difference.

 

[CalcSux78]

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)

Sub NewDataMerge()
Dim rData As Range
Dim Arr As Variant
Dim rng As Range
Dim cel As Range
Dim cID1%, cID2%, cID3%, cID4%
Dim R&, C&
Dim wb As Workbook
Dim dID2 As Object  'Dictionary
Dim dID4 As Object  'Dictionary




Set dID2 = CreateObject("Scripting.Dictionary")
Set dID4 = CreateObject("Scripting.Dictionary")


Set wb = Workbooks("Sheet2.xlsx")
With wb.Sheets("ID_DETAILS")
    Set rData = .UsedRange
    'find column for id2,id3,id4 within range
    cID2 = rData.Cells.Find(What:="ID2 Text").Column
    cID3 = rData.Cells.Find(What:="ID3 Text").Column
    cID4 = rData.Cells.Find(What:="ID4 Text").Column
    Arr = rData
    
    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
    
    Erase Arr
    Set rData = Nothing
    
    Set rData = ActiveSheet.UsedRange
    'make room for 2
    Set rData = rData.Resize(rData.Rows.Count, rData.Columns.Count + 2)
    
    Arr = rData
    cID1 = rData.Cells.Find(What:="ID1 Text").Column
    C = UBound(Arr, 2)  'last column #
    
    For R = LBound(Arr, 1) To UBound(Arr, 1)
        Arr(R, C - 1) = dID4(Arr(R, cID1))
        Arr(R, C) = dID2(Arr(R, cID1))
    Next R
    
    rData = Arr       'send data back to worksheet
End With
End Sub