Multiple sub-strings substitute - performance Issue in VBA

[luislucio]

Hi Everyone.
I'm struggling with a functionality in excel / VBA.

I have a list (one column) with 300.000+ entries. The length of each cell varies. For each cell over 35 chars, I need to perform substitutions in order to make it short.
For that purpose, I have a range "from" --> "to", so at each line I have "value to look for" --> "replace with", for instance

| Column A | Column B
Line 1 | Great Britain | GB
Line 2 | United States of America | USA

The "from" --> "to" range is rapidly growing (I guess will have 500+ entries)

For each line from my original list, I want to perform substitutions, step by step, so if after my first substitution the string is under 35 chars, will not look for another substitution to make, and move for the next line from my source. On the other hand, if after the first iteration is still over 35 chars, then should try the next one and so on, till reaches 35 chars (for instance 50 --> 40 --> 34 will stop at this step).

I have found this piece of code on another site, and have touched slightly. But the performance is really appalling (last run took over 8 hours).

Can someone please help me? I'm really struggling, and I don't have enough knowledge to go beyond this point.

The code is working, but the performance is really bad. This is really a problem because we need to run this several times, as we add additional substitution rules, until all the 300.000+ lines are under 35 chars.

-----

Sub MultiFindNReplace()
'Update 20140722
Dim Rng As Range
Dim Rng2 As Range
Dim InputRng As Range, ReplaceRng As Range
xTitleId = "Inserir Range"
Set InputRng = Application.Selection
Set InputRng = Application.InputBox("Range com Valores Originais", xTitleId, InputRng.Address, Type:=8)
Set ReplaceRng = Application.InputBox("Valores a Substituir:", xTitleId, Type:=8)
Application.ScreenUpdating = False
'For Each Rng In ReplaceRng.Columns(1).Cells
'    InputRng.Replace what:=Rng.Value, replacement:=Rng.Offset(0, 1).Value
For Each Rng In InputRng.Columns(1).Cells
If (Len(Rng.Value) > 35) Then
    
    For i = 1 To ReplaceRng.Rows.Count
    If (Len(Rng.Value) > 35) Then
        Rng.Value = Replace(Rng.Value, ReplaceRng.Cells(i, 1).Value, ReplaceRng.Cells(i, 2).Value)
    End If

    Next i
End If
Next
Application.ScreenUpdating = True
End Sub

-----



I really appreciate any help.
Thanks in advance for your inputs.