Need help improving this VBA Code to make it run faster

Hi Everyone,

I have this VBA Code that runs through over 200k rows. Right now, it runs super slow and I was wondering if anyone could help me edit it to make it run faster?

Sheet1 contains: Date (Column U), Extension (Column U), Number (Column V)
DID Corrections sheet contains: Extension (Column A), Number (Column B), Date From (Column C) and Date To (Column D)

Code:

---

Sub checkAndReplace()

Dim currentRowS1, currentRowS2 As Integer

Range("U1:T" + CStr(ThisWorkbook.Worksheets("Sheet1").UsedRange.Count) + ",A1:A" + CStr(ThisWorkbook.Worksheets("DID Corrections").UsedRange.Count)).Select

For currentRowS1 = 2 To ThisWorkbook.Worksheets("Sheet1").UsedRange.Count
    For currentRowS2 = 2 To ThisWorkbook.Worksheets("DID Corrections").UsedRange.Count
    If ThisWorkbook.Worksheets("Sheet1").Range("T" & currentRowS1).Text = ThisWorkbook.Worksheets("DID Corrections").Range("A" & currentRowS2).Text Then
        If DateDiff("d", ThisWorkbook.Worksheets("Sheet1").Range("T" & currentRowS1), ThisWorkbook.Worksheets("DID Corrections").Range("B" & currentRowS2)) <= 0 And DateDiff("d", ThisWorkbook.Worksheets("Sheet1").Range("T" & currentRowS1), ThisWorkbook.Worksheets("DID Corrections").Range("C" & currentRowS2)) >= 0 Then
        ThisWorkbook.Worksheets("Sheet1").Range("V" & currentRowS1).Value = ThisWorkbook.Worksheets("DID Corrections").Range("D" & currentRowS2).Value
        End If
    End If
    Next
Next

End Sub

---

Thanks!

For starters, your code probably runs through all rows more than once. UsedRange.Count yields the total number of used cells, not the number of rows.
Next thing to improve: Use arrays to hold the data rather than pulling it from each cell in turn:

This line :

Code:

---

vData = ActiveSheet.UsedRange.Value

---

is extremely fast compared to running through all cells in turn.

You can then loop through all values like so:

Code:

---

For lRow = 1 To Ubound(vData,1)
'Compare code goes here
Next

---

Finally, your dim statement is wrong:

Code:

---

Dim currentRowS1, currentRowS2 As Integer

---

means currentRowS1 is declared as Variant. Each variable needs its own " As " part.

try (untested):

Code:

---

Sub checkAndReplace()
Dim Rw1 As Long, Rw2 As Long, Sht1 As Worksheet, Sht2 As Worksheet
Set Sht1 = ThisWorkbook.Worksheets("Sheet1")
Set Sht2 = ThisWorkbook.Worksheets("DID Corrections")
'Range("U1:T" + CStr(Sht1.UsedRange.Count) + ",A1:A" + CStr(Sht2.UsedRange.Count)).Select

For Rw1 = 2 To Sht1.UsedRange.Rows.Count
  For Rw2 = 2 To Sht2.UsedRange.Rows.Count
    With Sht1.Range("T" & Rw1)
      If .Text = Sht2.Range("A" & Rw2).Text Then
        If DateDiff("d", .Value, Sht2.Range("B" & Rw2)) <= 0 And DateDiff("d", .Value, Sht2.Range("C" & Rw2)) >= 0 Then Sht1.Range("V" & Rw1).Value = Sht2.Range("D" & Rw2).Value
        'If Sht2.Range("B" & Rw2) - .Value <= 0 And Sht2.Range("C" & Rw2) - .Value >= 0 Then Sht1.Range("V" & Rw1).Value = Sht2.Range("D" & Rw2).Value
      End If
    End With
  Next
Next
End Sub

---

I didn't go down the route of doing it in-memory in case you already had values in column V of Sheet1 which you wanted to preserve; if you don't then it will be easy to do as Jan suggests and much faster.
There are two commented-out lines; the first .Select line I'm guessing is a debug line you're using to try and verify that you're comparing the right ranges, but it's not needed (and probably wouldn't select what you expect!).
The second is a possible alternative to the active line above it. It doesn't use datediff so will only work if your dates are all true Excel dates. It's there should the macro be still too slow for you and it only might speed it up a bit.

If the macro above is still too slow for you and there's nothing in column V that you're worried about overwriting then come back and I'll write an in-memory version which should be pdq (a sample file would be useful in that instance to help me with testing and elimnate any wrong guesses I may make about your data).

The other point to note is that your nested loops test each row in Sheet1 with all the rows in DID Corrections; if there are multiple rows in DID Corrections which satisfy the tests, only the last one encounterd will have its column D value showing in Sheet1. Two questions arise from this:
1. If only 1 row in DID Corrections will ever satisfy the tests, then we could speed up the macro by not bothering to check the rest of the rows in DID Corrections and move on to the next row of Sheet1.
2. If it is likely that there is more than 1 match in the DID Corrections sheet to each row of Sheet1 then what do you want to see in Sheet1 column V?

I think the logic is a little inconsistant compared to the message text but I'm not sure. I did not really follow which columns were being matched against which, so I used Const to define some columns and Dim-ed two WS variables to make it easier for me to read

I'd use .CurrentRegion instead of .UsedRange

I prefer to use .Cells(row, col) instead of constructing a Range(string). I find it easier to read (very personal opinion)

Not sure since there's no data, but if you find something during the inner loop, could you just exit to the next iteration on the outer loop?

You might make the variable names (currentRowS1 and currentRowS2) more self-documenting e.g. iDataRow and iDIDrow so that it's easier to follow ( very personal opinion #2)

Code:

---


Option Explicit

'I assume that Sheet1 Date in in Column T ??????????????????????????
'Sheet1 contains: Date (Column U), Extension (Column U), Number (Column V)
'DID Corrections sheet contains: Extension (Column A), Number (Column B), Date From (Column C) and Date To (Column D)

Const cDateCol As Long = 20
Const cExtCol As Long = 21
Const cNumberCol As Long = 22
Const cDIDExtCol As Long = 1
Const cDIDNumberCol As Long = 2
Const cDIDFromCol As Long = 3
Const cDIDToCol As Long = 4
 
Sub checkAndReplace()
    Dim wsOne As Worksheet, wsDID As Worksheet
   
    Dim currentRowS1 As Long, currentRowS2 As Long
   
'????    Range("U1:T" + CStr(wsOne.UsedRange.Count) + ",A1:A" + CStr(wsDID.UsedRange.Count)).Select
   
    Set wsOne = ThisWorkbook.Worksheets("Sheet1")
    Set wsDID = ThisWorkbook.Worksheets("DID Corrections")
   
    For currentRowS1 = 2 To wsOne.Cells(1, cExtCol).CurrentRegion.Rows.Count
       
        For currentRowS2 = 2 To wsDID.Cells(1, cDIDExtCol).CurrentRegion.Rows.Count
           
            If wsOne.Cells(currentRowS1, cDateCol).Text = wsDID.Cells(currentRowS2, cDIDExtCol).Text Then
               
                If DateDiff("d", wsOne.Cells(currentRowS1, cDateCol).Value, wsDID.Cells(currentRowS2, cDIDNumberCol).Value) <= 0 And _
                    DateDiff("d", wsOne.Cells(currentRowS1, cDateCol).Value, wsDID.Cells(currentRowS2, cDIDFromCol).Value) >= 0 Then
                   
                    wsOne.Cells(currentRowS1, cNumberCol).Value = wsDID.Cells(currentRowS2, cDIDToCol).Value
               
                End If
            End If
        Next
    Next
   
End Sub

---