Slow "comparison/replace" script

whatsup · #1 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

Thread Tools
Show Printable Version Email this Page
Display Modes
Switch to Linear Mode Hybrid Mode Switch to Threaded Mode

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