Hi
Your code isn't that bad, a 100,000 rows are done within
3.0 seconds. There are a few things still you should observe:
- Variables which are "Set" to, you should unload once they are of no use anymore
- WorksheetFunctions used in vba are slow
- Reading and especially writing from/to a worksheet is very slow, it should therefore be done rather in one strike
Observing point1 and 2 get's the same result in
2.26 seconds:
Code:
Sub RangeCompare2()
Dim arrCompare As Variant
Dim objdic As Object
Dim lngItem As Long
Dim Range2 As Range, c As Range
Dim dblTimer As Double
Set objdic = CreateObject("scripting.dictionary")
arrCompare = ActiveWorkbook.Sheets("Master Slide").Range("a4:a90")
On Error GoTo TheEnd
Set Range2 = Application.InputBox("Select Range2:", Title:="Get Range2", Type:=8)
dblTimer = Timer
For lngItem = 1 To UBound(arrCompare, 1)
If Len(CStr(arrCompare(lngItem, 1))) > 0 Then
objdic(arrCompare(lngItem, 1)) = ""
End If
Next lngItem
For Each c In Range2.Cells
If Not objdic.Exists(c.Value) Then
c.Value = "Others"
End If
Next c
MsgBox Timer - dblTimer
TheEnd:
Set objdic = Nothing
Set Range2 = Nothing
End Sub
Including point 3 - in the sample the selected Data is just in one row and you don't mind overwrite the entire selected Range - you get results in
0.31 seconds:
Code:
Sub RangeCompare3()
Dim arrCompare As Variant, arrData As Variant
Dim objdic As Object
Dim lngItem As Long
Dim Range2 As Range
Dim dblTimer As Double
Set objdic = CreateObject("scripting.dictionary")
arrCompare = ActiveWorkbook.Sheets("Master Slide").Range("a4:a90")
On Error GoTo TheEnd
Set Range2 = Application.InputBox("Select Range2:", Title:="Get Range2", Type:=8)
dblTimer = Timer
For lngItem = 1 To UBound(arrCompare, 1)
If Len(CStr(arrCompare(lngItem, 1))) > 0 Then
objdic(arrCompare(lngItem, 1)) = ""
End If
Next lngItem
arrData = Range2.Value
For lngItem = 1 To UBound(arrData, 1)
If Not objdic.Exists(arrData(lngItem, 1)) Then
arrData(lngItem, 1) = "Others"
End If
Next lngItem
Range2.Value = arrData
MsgBox Timer - dblTimer
TheEnd:
Set objdic = Nothing
Set Range2 = Nothing
End Sub