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.
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!
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.
Code:
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!
Last edited: