Multi find and replace part of cell

[tigerzen]

Trying to make replacements to raw data which comes in all sorts of variations eg Diploma could be dip, DP, Dipl. I've tried a macro but it doesn't do anything and that may be because I'm using a work computer. Looking for a formula to help convert the raw data with what's in the accompanying table. To be on the safe side, I'll need the formula to work on Office 2019 as I have a spare computer with that on it. If there's an obvious problem with my macro, then I'll fix it but I've used macros like these before and they've been fine so a formula/function will probably be how I go on this one. If there's an easier way to do it on Office 365, I'll look at that too. Open to suggestions here because I spend a lot of time cleaning data which is inconsistently entered.

Multireplace macro.xlsm
	A	B	C	D	E	F
1			Should read		Table for macro
2	Course		Course		Old	New
3	Adv Dip Science		Advanced Diploma Science		Adv	Advanced
4	As Deg Business		Associate Degree Business		Dip	Diploma
5	D Bus		Diploma Business		D	Diploma
6	Cer Maths		Certificate Maths		Cer	Certificate
Sheet1

The macro is

Sub MultiReplace()

Dim ListItem As Range
Dim ListToReplaceWithin As Range
Dim ListOfThingsThatWillChange As Range

On Error GoTo ErrorHandler

Set ListToReplaceWithin = Application.InputBox(Prompt:="Select the list you want to replace within:", Title:="Replace Items", Type:=8)
Set ListOfThingsThatWillChange = Application.InputBox(Prompt:="Select the list of items that you want to change:", Title:="Replace With", Type:=8)

For Each ListItem In ListOfThingsThatWillChange
ListToReplaceWithin.Replace What:=ListItem, Replacement:=ListItem.Offset(0, 1)
Next ListItem

Exit Sub

ErrorHandler:
Exit Sub

End Sub

 

[Alex Blakenburg]

Can you try changing the replace line to this:

ListToReplaceWithin.Replace What:=ListItem, Replacement:=ListItem.Offset(0, 1), LookAt:=xlPart, MatchCase:=False

 

[tigerzen]

Can you try changing the replace line to this:

ListToReplaceWithin.Replace What:=ListItem, Replacement:=ListItem.Offset(0, 1), LookAt:=xlPart, MatchCase:=False

Thanks Alex, that showed that macros can run on this machine. It has partially worked but possible macros aren't the way to go here. I got some funny results though, the output was:

AdvanceDiploma Diploma Science

Associate Degree Business

Diploma Bus

Certificate Maths

Diploma Sci

 

[Fuji]

Better to check each word.
try change to

Sub MultiReplace()

    Dim ListItem As Range
    Dim ListToReplaceWithin As Range
    Dim ListOfThingsThatWillChange As Range, x, myList, i&, ii&
    
    On Error GoTo ErrorHandler
    
    Set ListToReplaceWithin = Application.InputBox(Prompt:="Select the list you want to replace within:", Title:="Replace Items", Type:=8)
    Set ListOfThingsThatWillChange = Application.InputBox(Prompt:="Select the list of items that you want to change:", Title:="Replace With", Type:=8)
    myList = Application.Trim(ListToReplaceWithin.Resize(, 2))
    For Each ListItem In ListOfThingsThatWillChange
        x = Split(ListItem)
        For i = 0 To UBound(x)
            For ii = 1 To UBound(myList, 1)
                If x(i) = myList(ii, 1) Then x(i) = myList(ii, 2)
            Next
            ListItem = Join(x)
        Next
    Next ListItem
    
    Exit Sub
    
ErrorHandler:
    Exit Sub

End Sub

 

[tigerzen]

Better to check each word.
try change to

Sub MultiReplace()

    Dim ListItem As Range
    Dim ListToReplaceWithin As Range
    Dim ListOfThingsThatWillChange As Range, x, myList, i&, ii&
   
    On Error GoTo ErrorHandler
   
    Set ListToReplaceWithin = Application.InputBox(Prompt:="Select the list you want to replace within:", Title:="Replace Items", Type:=8)
    Set ListOfThingsThatWillChange = Application.InputBox(Prompt:="Select the list of items that you want to change:", Title:="Replace With", Type:=8)
    myList = Application.Trim(ListToReplaceWithin.Resize(, 2))
    For Each ListItem In ListOfThingsThatWillChange
        x = Split(ListItem)
        For i = 0 To UBound(x)
            For ii = 1 To UBound(myList, 1)
                If x(i) = myList(ii, 1) Then x(i) = myList(ii, 2)
            Next
            ListItem = Join(x)
        Next
    Next ListItem
   
    Exit Sub
   
ErrorHandler:
    Exit Sub

End Sub

Thanks Fuji, I gave this a try and pretty much did the same thing as in Post 3

 

[Fuji]

Did you add missing data like this?

Book1
	A	B	C	D	E	F	G
1			Should read		Table for macro
2	Course		Course		Old	New
3	Advanced Diploma Science		Advanced Diploma Science		Adv	Advanced
4	Associated Degree Business		Associate Degree Business		Dip	Diploma
5	Diploma Business		Diploma Business		D	Diploma
6	Certificate Maths		Certificate Maths		Cer	Certificate
7					As	Associated
8					Bus	Business
9					Deg	Degree
10
11
Sheet1

 

[tigerzen]

Did you add missing data like this?

Book1
	A	B	C	D	E	F	G
1			Should read		Table for macro
2	Course		Course		Old	New
3	Advanced Diploma Science		Advanced Diploma Science		Adv	Advanced
4	Associated Degree Business		Associate Degree Business		Dip	Diploma
5	Diploma Business		Diploma Business		D	Diploma
6	Certificate Maths		Certificate Maths		Cer	Certificate
7					As	Associated
8					Bus	Business
9					Deg	Degree
10
11
Sheet1

Hi Fuji, yes I made those changes but still got the same result.

 

[Fuji]

Strange,

Col.A in my previous post is the result of the code I posted...

 

[tigerzen]

Strange,

Col.A in my previous post is the result of the code I posted...

I could well be doing something wrong at my end, I'll work on it later today and see, thanks for your help.