More efficient VBA Find & Replace routine

[JeffGrant]

Hi All,

I have this Find and Replace VBA routine which does an ok job.

Sub BMFnR()

    'Range Variables
    Dim Rng1 As Range
    Dim Rng2 As Range
    Dim Rng3 As Range
    Dim Rng4 As Range
    
    'Variant Variables
    Dim FndList As Variant
    
    'Integer Variables
    Dim xx As Integer

    Application.ScreenUpdating = False

    'Sheet8.Select 'Import_csv
    With Sheet8
        lRow = .Cells(Rows.Count, 1).End(xlUp).Row
        
        'Data Range to look in
        Set Rng1 = .Range("G1:G" & lRow)
        
        'Data Range to Replace
        Set Rng2 = Sheet27.Range("A1").CurrentRegion
        Set Rng3 = .Range("AM1:AM" & lRow)
        Set Rng4 = .Range("AX1:AX" & lRow)
        FndList = Rng2.Range("A1").CurrentRegion
        
        MsgBox UBound(FndList)
        
            For xx = 3 To UBound(FndList)
                ' 1 & 2 are the column numbers
                Rng1.Cells.Replace What:=FndList(xx, 1), Replacement:=FndList(xx, 2), LookAt:=xlPart
                Rng3.Cells.Replace What:=FndList(xx, 1), Replacement:=FndList(xx, 2), LookAt:=xlPart
                Rng4.Cells.Replace What:=FndList(xx, 1), Replacement:=FndList(xx, 2), LookAt:=xlPart
            Next
    End With

    Application.ScreenUpdating = True
    Sheet5.Select 'Return to Home Sheet
    Range("A1").Select
End Sub

A sample of the Find & Replace data is this.

Find	Replace With
RST	RST
Rest.	RST
RST	RST
Rest.	RST
RST	RST
Restricted	RST
Maiden	Mdn
Rest 0 Metro Wins	RS0MW
Rest 1 Metro Win	RS1MW
Rest 2 Metro Wins	RS2MW
RST 0 Met Win-LY	RS0LY
RST 1 Met Win-LY	RS1LY
RST 2 Met Win-LY	RS2LY
RST 3 Met Win-LY	RS3LY

At the moment I have just on 100 pieces of thext that need to be searched for and replaced.

For example, in the above find and replace data, I am looking for RST (with no trailing spaced) or RST with 1 trainling space or RST with two trailing spaces. I understand I can us ethe Trim function etc, but that does not really give me a neat solution to be applied to other data.

The data to be searched comes from a daily imported csv file. Often with many thousands of records.

On the whole it works fine, but on occassion, the the VBA code does not find the intended text because of:

1. Leading ot training spaces or
2. A double (or more) spaces between some of the text or
3. ASCii Character 160 instead of a space or
4. Sometimes I can find a reason at all.

Is there a way in VBA or PQ that I can use to clean the import data to improved the possabillity of what is being searched ?

Thanks to all.

 

[cspengel]

Maybe try this formula first in an adjacent column next to your text.

=TRIM(CLEAN((SUBSTITUTE(A2,CHAR(160)," "))))

 

[Alex Blakenburg]

On a COPY of your workbook, give this a try:

Sub BMFnR_Mod()

    'Range Variables
    Dim Rng1 As Range
    Dim Rng2 As Range
    Dim Rng3 As Range
    Dim Rng4 As Range
    Dim RngWhole As Range
    Dim arrWhole As Variant
    Dim arr1 As Variant
    Dim arr3 As Variant
    Dim arr4 As Variant
    Dim shtCSV As Worksheet
    Dim shtFndList As Worksheet
    
    'Variant Variables
    Dim FndList As Variant
    
    'Integer Variables
    Dim xx As Integer
    Dim lRow As Long, lCol As Long

    Application.ScreenUpdating = False
    
    Set shtCSV = Sheet8
    Set shtFndList = Sheet27
    
    'Sheet8.Select 'Import_csv
    With shtCSV
        lRow = .Cells(Rows.Count, 1).End(xlUp).Row
        lCol = .Cells(1, Columns.Count).End(xlToLeft).Column
        
        'Data Range to look in
        Set Rng1 = .Range("G1:G" & lRow)
        
        'Data Range to Replace
        Set Rng2 = shtFndList.Range("A1").CurrentRegion
        Set Rng3 = .Range("AM1:AM" & lRow)
        Set Rng4 = .Range("AX1:AX" & lRow)
        FndList = Rng2.Value2
        
        MsgBox UBound(FndList)
        
        Set RngWhole = .Range(.Cells(1, "A"), .Cells(lRow, lCol))
        arrWhole = RngWhole.Value2
        
    End With
        
    ' Clean up known issues
    With Application
        arrWhole = .Substitute(arrWhole, ChrW(160), " ")
        arrWhole = .Trim(arrWhole)
        
        'Columns G=7 AX=39 AM=50
        arr1 = .Index(arrWhole, 0, 7)
        arr3 = .Index(arrWhole, 0, 39)
        arr4 = .Index(arrWhole, 0, 50)
        
        For xx = 3 To UBound(FndList)
            arr1 = .Substitute(arr1, FndList(xx, 1), FndList(xx, 2))
            arr3 = .Substitute(arr3, FndList(xx, 1), FndList(xx, 2))
            arr4 = .Substitute(arr4, FndList(xx, 1), FndList(xx, 2))
        Next xx
        
    End With
    
    ' The order matters write back arrWhole first
    shtCSV.Range("A1").Resize(UBound(arrWhole, 1), UBound(arrWhole, 2)).Value2 = arrWhole
    shtCSV.Range("G1").Resize(UBound(arr1)).Value2 = arr1
    shtCSV.Range("AM1").Resize(UBound(arr3)).Value2 = arr3
    shtCSV.Range("AX1").Resize(UBound(arr4)).Value2 = arr4

    Application.ScreenUpdating = True
    Sheet5.Select 'Return to Home Sheet
    Range("A1").Select
End Sub

 

[JeffGrant]

thanks guys. I appoloise for the late reply. Christmas/NY is my crazy time at work and I have not checked in for a while.

I have given Alex's code a good run. It is much fasterthan my original code.

Thanks Alex.

 

[Alex Blakenburg]

Thanks for following up on this. Glad we could help.