More efficient alternative to Find-Replace Loop?

[Paul]

I was tasked with looking through a 10,000 row by 20 column spreadsheet for 628 different ID Codes and replacing them with their Descriptions. The ID Codes could appear individually in any of these cells (200,000 cells!).

The list of ID's and Descriptions hardly ever changes, so I decided to create the two-dimensional array as part of the find-replace macro shown below (only a few lines of each dimension are shown).

My question isn't related to that (although if you can suggest a better alternative please do). The main "work" of the macro is the loop at the end of the array declarations, which essentially loops through all 628 ID codes in array dimension 1 and does a Find-ReplaceAll with its corresponding Description from array dimesion 2.

This task, manually, could take days. My macro has whittled the task down to 2.5 minutes on a 5-year-old laptop, but I was hoping one of the gurus might suggest an even better method than 628 loop iterations. If not, so be it, the end users will appreciate what I've done and then have to find something to do with their "free time."

Option Base 1
Option Explicit

Sub ReplaceStuff()
Dim i As Long
Dim arr(2, 628) As Variant
Application.ScreenUpdating = False
arr(1, 1) = "19142"
arr(1, 2) = "19144"
arr(1, 3) = "19146"
.
.
arr(1, 626) = "E97"
arr(1, 627) = "E98"
arr(1, 628) = "E99"
arr(2, 1) = "Company A"
arr(2, 2) = "Company B"
arr(2, 3) = "Region M"
.
.
arr(2, 626) = "Country A"
arr(2, 627) = "Company 42"
arr(2, 628) = "Country T"

For i = 1 To 628
Cells.Replace What:=arr(1, i), Replacement:=arr(2, i), LookAt:=xlWhole, _
    SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
    ReplaceFormat:=False
Next i
Application.ScreenUpdating = True
End Sub

Happy Excelling!

[shg]

No wonderful suggestion here.

If you had more iterations, I'd suggest doing a dummy Find that sets all of the saved parameters of the Replace, and then pass just What and Replacement arguments in the loop.

Similarly, two parallel arrays (Find and Replace), instead of one 2D array, might index slightly faster.

Still, for 628 iterations, I think the difference would be negligable if even measurable.

This task, manually, could take days. My macro has whittled the task down to 2.5 minutes on a 5-year-old laptop

Wow, this software stuff might catch on, huh?

[Leith Ross]

Hello Paul,

This method uses the Dictionary Object to make the comparisons. A variant array holds the cell values and is load using a block transfer. On my machine, this takes only a about 1 second to make 200,000 (10,000 rows x 20 columns) replacements.

I have 3 macros. One to create a list of 628 IDs and descriptions, one to lfill "Sheet1" with random IDs, and the last one to make the comparisons and replace the data. I will include them all here. "Sheet2" is used for the ID and descriptions and "Sheet1" is the test sheet. The total time is calculated at the end of the macro. You see the total time you can use a break point or Debug.Print or copy it to cell.

Sub CreateItemsAndDescriptions()

  Dim I As Integer
  Dim Rng As Range
  
    Set Rng = Worksheets("Sheet2").Range("A2:B629")
    
      For I = 1 To 628
        Rng.Item(I, 1) = I
        Rng.Item(I, 2) = "Item " & I
      Next I
      
End Sub

Sub FillTheWorksheet()

  Dim C As Long
  Dim Data(1 To 10000, 1 To 20) As Variant
  Dim R As Long
  Dim Rng As Range
  
    StartTime = Timer
    
    Set Rng = Worksheets("Sheet1").Range("A1:T10000")
    Randomize
    
      For R = 1 To 10000
        For C = 1 To 20
          Data(R, C) = Int((628 - 1 + 1) * Rnd + 1)
        Next C
      Next R
      
      Rng.Value = Data
      
      EndTime = Timer
      TotalTime = EndTime - StartTime
      
End Sub

Sub ReplacementTest()

  Dim C As Long
  Dim Data() As Variant
  Dim DSO As Object
  Dim I As Long
  Dim R As Long
  Dim Rng As Range
  
    StartTime = Timer
    
    Set DSO = CreateObject("Scripting.Dictionary")
    DSO.CompareMode = vbTextCompare
    
      Set Rng = Worksheets("Sheet2").Range("A2:B629")
      
        For I = 1 To 628
          If Not DSO.Exists(Rng.Item(I, 1)) Then
             DSO.Add Rng.Item(I, 1).Value, Rng.Item(I, 2).Text
          End If
        Next I
        
        Set Rng = Worksheets("Sheet1").Range("A1:T10000")
        ReDim DataData(1 To 10000, 1 To 20)
        Data = Rng.Value
          
          For R = 1 To 10000
            For C = 1 To 20
              If DSO.Exists(Data(R, C)) Then Data(R, C) = DSO(Data(R, C))
            Next C
          Next R
          
      Rng.Value = Data
      Set DSO = Nothing
       
    EndTime = Timer
    TotalTime = EndTime - StartTime
     
End Sub

[Paul]

Thanks, SHG and Leith. I'll play with this later today and see how it goes. Happy Groundhogs Day!

[Paul]

Leith... amazing. With some adjustments I have the entire macro (creating array, adding it to new sheet, creating DSO, replacing values) running in about 3 seconds.

I'll definitely have to use DSO more in the future. Thanks a ton!

Adjusted code shown below. Only thing I noticed is that for cells that weren't replaced, if they were numeric format they were converted to currency format. To get around that I just formatted the entire replacement range as text ahead of the replacement step.

Option Base 1
Option Explicit

Sub ReplaceStuff()
Dim arr(2, 629) As Variant
Application.ScreenUpdating = False
arr(1, 1) = "19142"
arr(1, 2) = "19144"
arr(1, 3) = "19146"
.
.
arr(1, 627) = "E98"
arr(1, 628) = "E99"
arr(1, 629) = "E06500"
arr(2, 1) = "Company A"
arr(2, 2) = "Company B"
arr(2, 3) = "Company C"
.
.
arr(2, 627) = "Long Description X"
arr(2, 628) = "Long Description Y"
arr(2, 629) = "Long Description Z"

Sheets.Add.Name = "CodeList"
With Sheets("CodeList")
    .Range("A:B").NumberFormat = "@"
    .Range("A1:B" & UBound(arr, 2)).Value = Application.Transpose(arr)
End With
Call ReplacementDSO
Application.DisplayAlerts = False
Sheets("CodeList").Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

Sub ReplacementDSO()

  Dim C As Long, Data() As Variant, DSO As Object
  Dim I As Long, R As Long, Rng As Range, lr As Long
  Dim lcode As Long
  
    Set DSO = CreateObject("Scripting.Dictionary")
    DSO.CompareMode = vbTextCompare
      lcode = Sheets("CodeList").Range("A" & Rows.Count).End(xlUp).Row
      Set Rng = Worksheets("CodeList").Range("A1:B" & lcode)
      
        For I = 1 To lcode
          If Not DSO.Exists(Rng.Item(I, 1)) Then
             DSO.Add Rng.Item(I, 1).Value, Rng.Item(I, 2).Text
          End If
        Next I
        
        lr = Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
        Set Rng = Worksheets("Sheet1").Range("A25:I" & lr)
        Rng.NumberFormat = "@"
        ReDim Data(1 To lr - 24, 1 To 9)
        Data = Rng.Value
          
          For R = 1 To lr - 24
            For C = 1 To 9
              If DSO.Exists(Data(R, C)) Then Data(R, C) = DSO(Data(R, C))
            Next C
          Next R
          
      Rng.Value = Data
      Set DSO = Nothing
End Sub

[shg]

Good job, Leith!