Macro to replace text based on reference list

[Anglais428v2]

I have a list of company names in range G2:G30000. I want to replace certain suffix (e.g. Inc, GmBH etc.) from their names. I have a list of suffix in range B2:B500 (cell B2 is '& Co' for example)

I have a macro that works well but for only the first instance and I need it to be dynamic:

Range("G2").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Replace What:="& CO*", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False, FormulaVersion:=xlReplaceFormula2
Selection.End(xlUp).Select
Range("G2").Select

Note I am using the asterix after the text & CO as I want to replace any text to the right of '& CO'.
What I need is the above put into a loop and replace the "What= "& CO*" with the cell reference B2 ('& CO' is housed within cell B2). I then want the function to loop and go to cell B3 (which contains '(Pty) Ltd'), do the replace and so on until cell B500.

Any advise?

Thanks

 

[HighAndWilder]

I have a list of company names in range G2:G30000. I want to replace certain suffix (e.g. Inc, GmBH etc.) from their names. I have a list of suffix in range B2:B500 (cell B2 is '& Co' for example)

I have a macro that works well but for only the first instance and I need it to be dynamic:

Range("G2").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Replace What:="& CO*", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False, FormulaVersion:=xlReplaceFormula2
Selection.End(xlUp).Select
Range("G2").Select

Note I am using the asterix after the text & CO as I want to replace any text to the right of '& CO'.
What I need is the above put into a loop and replace the "What= "& CO*" with the cell reference B2 ('& CO' is housed within cell B2). I then want the function to loop and go to cell B3 (which contains '(Pty) Ltd'), do the replace and so on until cell B500.

Any advise?

Thanks

Can you please provide a good set of sample data using XL2BB?

Thanks

 

[Anglais428v2]

Column B:

Suffix (to be replaced)

& Co

, Inc

, Incorporated

ltd

GmbH

Column G

Company name (original)	Desired result
Microsoft, Inc	Microsoft
Porsche GmbH	Porsche
1E ltd	1E
ACO Ahlmann SE & Co KG	ACO Ahlmann SE

 

[HighAndWilder]

Try this on a copy of your data.

NOTE the changes that you need to make.

Public Sub subReplaceText()
Dim arrToReplace() As Variant
Dim arrReplaceBy() As Variant
Dim WsData As Worksheet
Dim i As Integer
Dim ii As Integer

  Set WsData = Worksheets("Data")
  ' CHANGE THIS LINE (Worksheet Name) AS APPROPRIATE.
  
  WsData.Activate

  With WsData
  
    arrToReplace = .Range("G2:G" & Cells(Rows.Count, 7).End(xlUp).Row)
  ' CHANGE THIS LINE (Range) AS APPROPRIATE.
  
    arrReplaceBy = .Range("B2:B" & Cells(Rows.Count, 2).End(xlUp).Row)
    ' CHANGE THIS LINE (Range) AS APPROPRIATE.
  
  End With
  
  For i = 1 To UBound(arrToReplace)
  
    For ii = 1 To UBound(arrReplaceBy)
    
      If Right(arrToReplace(i, 1), Len(arrReplaceBy(ii, 1))) = arrReplaceBy(ii, 1) Then
            
        arrToReplace(i, 1) = Trim(Left(arrToReplace(i, 1), Len(arrToReplace(i, 1)) - Len(arrReplaceBy(ii, 1))))
    
      End If
    
    Next ii
      
  Next i
  
  WsData.Range("H2").Resize(UBound(arrToReplace), 1).Value = arrToReplace
  ' CHANGE THIS RANGE (H2 - Start of destination range) AS APPROPRIATE.
  
End Sub

 

[Anglais428v2]

Many thanks HighandWilder, it appears to be working great!

 

[HighAndWilder]

Many thanks HighandWilder, it appears to be working great!

I'm glad that it did the job for you.