Find and Replace selective words to abbreviations using macro in excel

[Tissot786786]

Dear All

I have a list of words with abbreviations .I need one macro coding please help me.

In sheet 1 i have master data i.e. customer name,address and email id.If the address such as St. louis university 1546 ,UK. In this i want only "University" word to be changed to "UNIV".

My result should be "St. louis UNIV 1546,UK".

This is one example.I have almost 2000 words with abbreviations.If i put the master data in one sheet and run macro, i need only the words to be changed and others should remain as it is.

Please help me iam new to excel macro VBA.

 

[ranman256]

paste this code into a module.
it assumes you have a sheet called 'abbrevs', with Col A having the Word to find, and col B with the abbrev.
then it goes to 'sheet1' and replace all abbrevs in the list.

Public gcolWords As New Collection

Public Sub ReplaceAllWrds()
Dim vWord, vAbv, itm
Dim i As Integer

LoadAbbrevs

Sheets("sheet1").Activate
Cells.Select
For Each itm In gcolWords
   i = InStr(itm, ":")
   vWord = Left(itm, i - 1)
   vAbv = Mid(itm, i + 1)
   Replace1Wrd vWord, vAbv
Next
Set gcolWords = Nothing
End Sub

Private Sub Replace1Wrd(ByVal pvWrd, pvAbv)
On Error Resume Next


    Selection.Replace What:=pvWrd, Replacement:=pvAbv, LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
End Sub

Private Sub LoadAbbrevs()
Dim vWord, vAbv, vItm

Sheets("abbrevs").Activate
Range("A2").Select
While ActiveCell.Value <> ""
   vWord = ActiveCell.Offset(0, 0).Value
   vAbv = ActiveCell.Offset(0, 1).Value
   vItm = vWord & ":" & vAbv
   
   gcolWords.Add vItm
   ActiveCell.Offset(1, 0).Select   'next row
Wend
End Sub