VBA to replace multiple values - include list

[zx6roo]

I am currently using this code to replace words in my data:

Sub MultiReplace()
On Error GoTo errorcatch
Dim arrRules() As Variant

strSheet = "renamelist"
strRules = "A1:A100"

Set rngCol1 = Sheets(strSheet).Range(strRules)
Set rngCol2 = rngCol1.Offset(0, 1)
arrRules = Application.Union(rngCol1, rngCol2)

For i = 1 To UBound(arrRules)
Selection.Replace What:=arrRules(i, 1), Replacement:=arrRules(i, 2), _
LookAt:=xlWhole, MatchCase:=True
Next i
errorcatch:
End Sub

The tab containing my data is copied into another file and the renamelist tab isn't. I can't put the renamelist onto columns on the main tab because my users wipe it out. Is it possibly to hardcode the renamelist data into the code and avoid having one hundred of these lines?

Cells.Replace What:="Apples", Replacement:="Red", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Cells.Replace What:="Pears", Replacement:="Blue", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Cells.Replace What:="Bananas", Replacement:="Green", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False

 

[Yongle]

Why not maintain your list of replacement words in a separate file ?

In example below
- ReplaceList.xlsx in found in folder C:\Test
- the list is on sheet named "List" in columns A & B with no empty rows (to allow CurrentRegion to determine range)
- the data is on a sheet named "Data" in workbook named DataFile123.xlsx

VBA
- opens ReplaceList
- creates an array of replacement values
- closes ReplaceList without saving it
- opens DataFile123
- replaces values
- saves the file

Sub ReplaceValues()
'create array from closed workbook
    Dim wbData As Workbook, Wb As Workbook, x As Long, a
    Set Wb = Workbooks.Open("[COLOR=#ff0000]C:\Test\ReplaceList.xlsx[/COLOR]")
    a = Wb.Sheets("[COLOR=#008080]List[/COLOR]").Range("A1").CurrentRegion
    Wb.Close (False)
    Set wbData = Workbooks.Open("C:\Test\[COLOR=#ff0000]DataFile123.xlsx[/COLOR]")
'replace values in sheet named "[COLOR=#008080]Data[/COLOR]"
    With wbData.Sheets("Data").Cells
        For x = 1 To UBound(a)
            .Replace What:=a(x, 1), Replacement:=a(x, 2), _
            LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
        Next x
    End With
    With wbData
        .Save
            '.Close (False)        'remove apostrophe before .Close to close the file automatically after update
    End With
End Sub

ReplaceList.xlsx looks like this:

Excel 2016 (Windows) 32 bit
[Table="width:, class:head"][tr=bgcolor:#E0E0F0][th] [/th][th]

A​

[/th][th]

B​

[/th][/tr]
[tr=bgcolor:#FFFFFF][td=bgcolor:#E0E0F0]

1​

[/td][td]Apples[/td][td]Red[/td][/tr]

[tr=bgcolor:#FFFFFF][td=bgcolor:#E0E0F0]

2​

[/td][td]Pears[/td][td]Blue[/td][/tr]

[tr=bgcolor:#FFFFFF][td=bgcolor:#E0E0F0]

3​

[/td][td]Bananas[/td][td]Green[/td][/tr]
[/table][Table="width:, class:grid"][tr][td]Sheet: List[/td][/tr][/table]