Slow "comparison/replace" script

whatsup · #2 06-12-2014, 06:52 AM

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

Similar Threads
Thread	Thread Starter	Forum	Replies	Last Post
Wierd "script code" in a downloaded .doc file	CNBarnes	Word	2	10-18-2012 02:07 AM
replace data from variable with "sub and super script" from excel to word by vba	krishnaoptif	Word VBA	9	06-22-2012 05:08 AM
How to choose a "List" for certain "Heading" from "Modify" tool?	Jamal NUMAN	Word	2	07-03-2011 03:11 AM
Rules and Alerts: "run a script"?	discountvc	Outlook	0	06-15-2010 07:36 AM
An "error has occurred in the script on this page"	decann	Outlook	8	09-03-2009 08:54 AM