Improving Speed Comparing Multiple Columns

[David Hill]

I would like to please get assistance to improving speed for this particular following code because I have between 10,000 to 20,000 records.
In columns J and K are dates. In column L are integers.


Sub COMPAREMULTIPLECOLUMNS()

Dim sh1 As Worksheet, sh2 As Worksheet

Dim j As Long, i As Long, lastrow1 As Long, lastrow2 As Long

Set sh1 = Worksheets("CURRENT")

Set sh2 = Worksheets("PREVIOUS")



lastrow1 = sh1.Cells(Rows.Count, "A").End(xlUp).Row

lastrow2 = sh2.Cells(Rows.Count, "A").End(xlUp).Row



For i = 2 To lastrow1

For j = 2 To lastrow2

If sh1.Cells(i, "F").Value = sh2.Cells(j, "F").Value Then

If sh1.Cells(i, "J").Value <> sh2.Cells(j, "J").Value Then

sh1.Cells(i, "R").Value = sh2.Cells(j, "J").Value

End If

End If

If sh1.Cells(i, "F").Value = sh2.Cells(j, "F").Value Then

If sh1.Cells(i, "K").Value <> sh2.Cells(j, "K").Value Then

sh1.Cells(i, "S").Value = sh2.Cells(j, "K").Value

End If

End If

If sh1.Cells(i, "F").Value = sh2.Cells(j, "F").Value Then

If sh1.Cells(i, "L").Value <> sh2.Cells(j, "L").Value Then

sh1.Cells(i, "T").Value = sh2.Cells(j, "L").Value

End If

End If

Next j

Next i

End Sub


I would greatly appreciate any assistance.

[princ_wns]

Plese try this one.


Sub OptimzeSpeed()

Dim varArrSheet1 As Variant
Dim varArrSheet2 As Variant

Dim lngCtr1 As Long
Dim lngCtr2 As Long

Const strSheetName1 As String = "CURRENT"
Const strSheetName2 As String = "PREVIOUS"

varArrSheet1 = ThisWorkbook.Worksheets(strSheetName1).UsedRange
varArrSheet2 = ThisWorkbook.Worksheets(strSheetName2).UsedRange

ThisWorkbook.Worksheets(strSheetName1).UsedRange.C learContents


For lngCtr1 = LBound(varArrSheet1) To UBound(varArrSheet1)
For lngCtr2 = LBound(varArrSheet2) To UBound(varArrSheet2)
If varArrSheet1(lngCtr1, 5) = varArrSheet1(lngCtr2, 5) Then
If varArrSheet1(lngCtr1, 10) <> varArrSheet1(lngCtr2, 10) Then
varArrSheet1(lngCtr1, 18) = varArrSheet1(lngCtr2, 10)
End If

If varArrSheet1(lngCtr1, 11) <> varArrSheet1(lngCtr2, 11) Then
varArrSheet1(lngCtr1, 19) = varArrSheet1(lngCtr2, 11)
End If

If varArrSheet1(lngCtr1, 12) <> varArrSheet1(lngCtr2, 12) Then
varArrSheet1(lngCtr1, 20) = varArrSheet1(lngCtr2, 12)
End If
End If
Next
Next
With ThisWorkbook.Worksheets(strSheetName1)
.UsedRange.ClearContents
.Range(A1).Resize(UBound(varArrSheet1, 1), UBound(varArrSheet1, 2)) = varArrSheet1
End With

End Sub



Regards
Prince

[David Hill]

Thank you for your replay Prince. I get the subscript out of range error at this line.


If varArrSheet1(lngCtr1, 5) = varArrSheet1(lngCtr2, 5) Then

[snb]

It would have been nice if you had described what the code should do under what conditions...


Sub M_snb()
sn = Sheets("Current").Cells(1).CurrentRegion.Offset(, 5).Resize(, 15)
sp = Sheets("Previous").Cells(1).CurrentRegion.Offset(, 5).Resize(, 15)

With CreateObject("scripting.dictionary")
For j = 1 To UBound(sn)
.Item(sn(j, 1)) = Application.Index(sn, j, 0)
Next

For j = 1 To UBound(sp)
st = .Item(sp(j, 1))
st(13) = sp(j, 5)
st(14) = sp(j, 6)
st(15) = sp(j, 7)
.Item(sp(j, 1)) = Application.Index(st)
Next

Sheets("CURRENT").Cells(1).CurrentRegion.Offset(, 5).Resize(, 15) = Application.Index(.items, 0, 0)
End With
End Sub

[David Hill]

Thanks for replying snb. I'm trying to identify date and timeframe changes from one report to the next. I tried your code and got a compile error - "array is expected" on this piece of code.


For j = 1 To UBound(sn)

[snb]

check
- there are no empty cells in row 1 A1:T1
- no empty cells in column A

[princ_wns]

Hi Devid,


Can you please share your workbook, So that we can provide you exact solution.

Regards
Prince