More efficient VBA Find & Replace routine

JeffGrant

Well-known Member
Joined
Apr 7, 2021
Messages
558
Office Version
  1. 365
Platform
  1. Windows
Hi All,

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



VBA Code:
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.

FindReplace With
RSTRST
Rest.RST
RSTRST
Rest.RST
RSTRST
RestrictedRST
MaidenMdn
Rest 0 Metro WinsRS0MW
Rest 1 Metro WinRS1MW
Rest 2 Metro WinsRS2MW
RST 0 Met Win-LYRS0LY
RST 1 Met Win-LYRS1LY
RST 2 Met Win-LYRS2LY
RST 3 Met Win-LYRS3LY

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.
 

Excel Facts

Fastest way to copy a worksheet?
Hold down the Ctrl key while dragging tab for Sheet1 to the right. Excel will make a copy of the worksheet.
Maybe try this formula first in an adjacent column next to your text.

=TRIM(CLEAN((SUBSTITUTE(A2,CHAR(160)," "))))
 
Upvote 0
On a COPY of your workbook, give this a try:

VBA Code:
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
 
Upvote 0
Solution
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.
 
Upvote 0

Forum statistics

Threads
1,223,880
Messages
6,175,155
Members
452,615
Latest member
bogeys2birdies

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top