PDA

View Full Version : Need help improving this VBA Code to make it run faster



beergum
06-18-2014, 09:24 PM
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)



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!

Jan Karel Pieterse
06-18-2014, 10:55 PM
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 :


vData = ActiveSheet.UsedRange.Value

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

You can then loop through all values like so:


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

Finally, your dim statement is wrong:


Dim currentRowS1, currentRowS2 As Integer

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

p45cal
06-19-2014, 03:15 AM
try (untested):
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?

Paul_Hossler
06-19-2014, 09:05 AM
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)






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