Multi Find Replace Keywords with Abbreviation from Range - How to loop through a changing range

gjdavis123 · Dec 19, 2014

Multi Find Replace Keywords with Abbreviation from Range - How to loop through a changing range

This is my first post, so please be patient.
I have a sheet with data in col B. This is the data to be updated. This VBA finds the keywords in col B that match the keywords in col N and replaces the found words in col B with the matching abbreviation. This runs well for a fixed number of rows in col N, currently set to 10. I really need it to be as much as 100 rows yet I prefer it to be dynamic. The method used here scans col B and writes update to col C. It then scans col C writes update to col d. etc... through col L. By the time it gets to col L, all 10 abbreviation have been updated. This causes col creep so I will move cols N and O to a separate sheet which is no problem for me.
It seems the coding is inefficient and limited. Is there a way to change it to avoid column creep and/or make it more dynamic by looping through the changing ranges?
Windows 7, Excel 2013
This code works but is limited to 10 keywords/replacements in columns N and O. Example of current before and after results are below the script.

Code:

Option Explicit
Sub MultiReplaceEDITrange()
    Dim rg As Range, c As Range, d As Range, e As Range, f As Range, g As Range, h As Range, ii As Range, j As Range, k As Range, l As Range, m As Range
    Dim vLongName As Variant
    Dim vAbbrev As Variant
    Dim I As Long
    Dim x As Long
    Dim cl As Long
    Dim lrow As Long
     
    On Error Resume Next
    Application.ScreenUpdating = False
    
     'Long names in Col 14 (N), Abbr in next Col (O)
    cl = 14
     
     'get last row in Names Col
    lrow = Cells(65536, cl).End(xlUp).Row
     
     'setup arrays
    ReDim vLongName(lrow)
    ReDim vAbbrev(lrow)
     
     'load array1 with names
    For x = 1 To lrow
        vLongName(x) = Cells(x, cl)
    Next x
     
     'load array2 with abbr
    For x = 1 To lrow
        vAbbrev(x) = Cells(x, cl + 1)
    Next x
Set rg = Range("B1", Cells(Rows.Count, "B").End(xlUp))
For Each c In rg
 
    For I = LBound(vLongName) To UBound(vLongName)
          
        If InStr(1, c.Text, vLongName(I), vbTextCompare) > 0 Then
            c(1, 2).Value = Replace(c.Text, vLongName(I), vAbbrev(I), Compare:=vbTextCompare)
      End If
        
    Next I
Next c
Set rg = Range("C1", Cells(Rows.Count, "C").End(xlUp))
For Each d In rg
 
    For I = LBound(vLongName) To UBound(vLongName)
          
        If InStr(1, d.Text, vLongName(I), vbTextCompare) > 0 Then
            d(1, 2).Value = Replace(d.Text, vLongName(I), vAbbrev(I), Compare:=vbTextCompare)
      End If
        
    Next I
Next d
Set rg = Range("D1", Cells(Rows.Count, "D").End(xlUp))
For Each e In rg
 
    For I = LBound(vLongName) To UBound(vLongName)
          
        If InStr(1, e.Text, vLongName(I), vbTextCompare) > 0 Then
            e(1, 2).Value = Replace(e.Text, vLongName(I), vAbbrev(I), Compare:=vbTextCompare)
      End If
        
    Next I
Next e
Set rg = Range("E1", Cells(Rows.Count, "E").End(xlUp))
For Each f In rg
 
    For I = LBound(vLongName) To UBound(vLongName)
          
        If InStr(1, f.Text, vLongName(I), vbTextCompare) > 0 Then
            f(1, 2).Value = Replace(f.Text, vLongName(I), vAbbrev(I), Compare:=vbTextCompare)
      End If
        
    Next I
Next f
Set rg = Range("F1", Cells(Rows.Count, "F").End(xlUp))
For Each g In rg
 
    For I = LBound(vLongName) To UBound(vLongName)
          
        If InStr(1, g.Text, vLongName(I), vbTextCompare) > 0 Then
            g(1, 2).Value = Replace(g.Text, vLongName(I), vAbbrev(I), Compare:=vbTextCompare)
      End If
        
    Next I
Next g
Set rg = Range("G1", Cells(Rows.Count, "G").End(xlUp))
For Each h In rg
 
    For I = LBound(vLongName) To UBound(vLongName)
          
        If InStr(1, h.Text, vLongName(I), vbTextCompare) > 0 Then
            h(1, 2).Value = Replace(h.Text, vLongName(I), vAbbrev(I), Compare:=vbTextCompare)
      End If
        
    Next I
Next h
Set rg = Range("H1", Cells(Rows.Count, "H").End(xlUp))
For Each ii In rg
 
    For I = LBound(vLongName) To UBound(vLongName)
          
        If InStr(1, ii.Text, vLongName(I), vbTextCompare) > 0 Then
            ii(1, 2).Value = Replace(ii.Text, vLongName(I), vAbbrev(I), Compare:=vbTextCompare)
      End If
        
    Next I
Next ii
Set rg = Range("I1", Cells(Rows.Count, "I").End(xlUp))
For Each j In rg
 
    For I = LBound(vLongName) To UBound(vLongName)
          
        If InStr(1, j.Text, vLongName(I), vbTextCompare) > 0 Then
            j(1, 2).Value = Replace(j.Text, vLongName(I), vAbbrev(I), Compare:=vbTextCompare)
      End If
        
    Next I
Next j
Set rg = Range("J1", Cells(Rows.Count, "J").End(xlUp))
For Each k In rg
 
    For I = LBound(vLongName) To UBound(vLongName)
          
        If InStr(1, k.Text, vLongName(I), vbTextCompare) > 0 Then
            k(1, 2).Value = Replace(k.Text, vLongName(I), vAbbrev(I), Compare:=vbTextCompare)
      End If
        
    Next I
Next k
Set rg = Range("K1", Cells(Rows.Count, "K").End(xlUp))
For Each l In rg
 
    For I = LBound(vLongName) To UBound(vLongName)
          
        If InStr(1, l.Text, vLongName(I), vbTextCompare) > 0 Then
            l(1, 2).Value = Replace(l.Text, vLongName(I), vAbbrev(I), Compare:=vbTextCompare)
      End If
        
    Next I
Next l
Set rg = Range("L1", Cells(Rows.Count, "L").End(xlUp))
For Each m In rg
 
    For I = LBound(vLongName) To UBound(vLongName)
          
        If InStr(1, m.Text, vLongName(I), vbTextCompare) > 0 Then
            m(1, 2).Value = Replace(m.Text, vLongName(I), vAbbrev(I), Compare:=vbTextCompare)
      End If
        
    Next I
Next m
Application.ScreenUpdating = True
End Sub

Before:

Description(Required)

Keyword

Abbrev

Sport Swimming

sport

sprt

Gymnastics Speed Skating Cross Country Skiing

swimming

swimng

Short-Track Speed Skating Diving Cycling

country

contry

Ski Jumping Nordic Combined Athletics Table Tennis

jumping

jump

Synchronized Swimming Shooting Rowing Fencing Equestrian

single

sngl

Gymnastics

synchronized

sync

Short-Track Speed Skating

gymnastics

gym

Sport

side

1S

Gymnastics

combined

combi

Short-Track Speed Skating

Hybrid

hybrd

Ski Jumping

Synchronized Swimming

Ski Jumping Nordic Combined Athletics Table Tennis

Gymnastics

Short-Track Speed Skating

Ski Jumping

Ski Jumping Nordic Combined Athletics Table Tennis

Short-Track Speed Skating

Sport

Gymnastics

Short-Track Speed Skating

Ski Jumping

Synchronized Swimming

After:

Description(Required)

Keyword

Abbrev

Sport Swimming

Sport swimng

sprt swimng

sport

sprt

Gymnastics Speed Skating Cross Country Skiing

gym Speed Skating Cross Country Skiing

gym Speed Skating Cross contry Skiing

swimming

swimng

Short-Track Speed Skating Diving Cycling

country

contry

Ski Jumping Nordic Combined Athletics Table Tennis

Ski Jumping Nordic combi Athletics Table Tennis

Ski jump Nordic combi Athletics Table Tennis

jumping

jump

Synchronized Swimming Shooting Rowing Fencing Equestrian

sync Swimming Shooting Rowing Fencing Equestrian

sync swimng Shooting Rowing Fencing Equestrian

single

sngl

Gymnastics

gym

synchronized

sync

Short-Track Speed Skating

gymnastics

gym

Sport

sprt

side

1S

Gymnastics

gym

combined

combi

Short-Track Speed Skating

Hybrid

hybrd

Ski Jumping

Ski jump

Synchronized Swimming

sync Swimming

sync swimng

Ski Jumping Nordic Combined Athletics Table Tennis

Ski Jumping Nordic combi Athletics Table Tennis

Ski jump Nordic combi Athletics Table Tennis

Gymnastics

gym

Short-Track Speed Skating

Ski Jumping

Ski jump

Ski Jumping Nordic Combined Athletics Table Tennis

Ski Jumping Nordic combi Athletics Table Tennis

Ski jump Nordic combi Athletics Table Tennis

Ski Jumping Nordic Combined Athletics Table Tennis

Ski Jumping Nordic combi Athletics Table Tennis

Ski jump Nordic combi Athletics Table Tennis

Short-Track Speed Skating

Sport

sprt

Gymnastics

gym

Short-Track Speed Skating

Ski Jumping

Ski jump

Synchronized Swimming

sync Swimming

sync swimng

Thanks for looking! Jeff

hiker95 · Dec 19, 2014

gjdavis123,

Welcome to the MrExcel forum.

We can not tell where your raw data is located, sheetname(s), cells, rows, columns, and, we can not tell where the results should be, sheetname(s), cells, rows, columns.

Based on what I have seen so far, screenshots will probably not do.

Can we see your actual workbook/worksheet(s) containing the raw data, and, the results (manually formatted by you)?

You can upload your workbook to Box Net,
sensitive data changed
mark the workbook for sharing
and provide us with a link to your workbook.

gjdavis123 · Dec 19, 2014

The spreadsheet can be downloaded from the link below:

[url]https://app.box.com/s/08f718pmmmavfrjzu1ge

[/URL]

hiker95 said:
gjdavis123,

Welcome to the MrExcel forum.

We can not tell where your raw data is located, sheetname(s), cells, rows, columns, and, we can not tell where the results should be, sheetname(s), cells, rows, columns.

Based on what I have seen so far, screenshots will probably not do.

Can we see your actual workbook/worksheet(s) containing the raw data, and, the results (manually formatted by you)?

You can upload your workbook to Box Net,
sensitive data changed
mark the workbook for sharing
and provide us with a link to your workbook.

hiker95 · Dec 19, 2014

gjdavis123,

Thanks for the workbook.

I will need you to make a change in the VBA Editor, so that I will be able to view the VBAProject(ReplaceKeywords...........)

Then post the workbook again on BOX.

gjdavis123 · Dec 19, 2014

https://app.box.com/s/tbuq2mshac67zg1k05l4 new link. Use the .xlsm file. I cod

hiker95,

I tried to locate password for the project to unprotect it but never found any. If this doesn't work it would be very easy to set up the following:

Open a new WB
Paste the follwing in col B

Description(Required) (heading)
Sport Swimming
Gymnastics Speed Skating Cross Country Skiing
Short-Track Speed Skating Diving Cycling
Ski Jumping Nordic Combined Athletics Table Tennis
Synchronized Swimming Shooting Rowing Fencing Equestrian
Gymnastics
Short-Track Speed Skating
Sport
Gymnastics
Short-Track Speed Skating
Ski Jumping
Synchronized Swimming
Ski Jumping Nordic Combined Athletics Table Tennis
Gymnastics
Short-Track Speed Skating
Ski Jumping
Ski Jumping Nordic Combined Athletics Table Tennis
Ski Jumping Nordic Combined Athletics Table Tennis
Short-Track Speed Skating
Sport
Gymnastics
Short-Track Speed Skating
Ski Jumping
Synchronized Swimming

Paste this in col N

Keyword (heading)
sport
swimming
country
jumping
single
synchronized
gymnastics
side
combined
Hybrid

Paste this in col O

Abbrev (heading)
sprt
swimng
contry
jump
sngl
sync
gym
1S
combo
hybrd

copy and paste this vba and run. It works, but is limited.

Option Explicit
Sub MultiReplaceEDITrange()

Dim rg As Range, c As Range, d As Range, e As Range, f As Range, g As Range, h As Range, ii As Range, j As Range, k As Range, l As Range, m As Range
Dim vLongName As Variant
Dim vAbbrev As Variant
Dim I As Long
Dim x As Long
Dim cl As Long
Dim lrow As Long

On Error Resume Next
Application.ScreenUpdating = False

'Long names in Col 14 (N), Abbr in next Col (O)
cl = 14

'get last row in Names Col
lrow = Cells(65536, cl).End(xlUp).Row

'setup arrays
ReDim vLongName(lrow)
ReDim vAbbrev(lrow)

'load array1 with names
For x = 1 To lrow
vLongName(x) = Cells(x, cl)
Next x

'load array2 with abbr
For x = 1 To lrow
vAbbrev(x) = Cells(x, cl + 1)
Next x
Set rg = Range("B1", Cells(Rows.Count, "B").End(xlUp))

For Each c In rg

For I = LBound(vLongName) To UBound(vLongName)

If InStr(1, c.Text, vLongName(I), vbTextCompare) > 0 Then
c(1, 2).Value = Replace(c.Text, vLongName(I), vAbbrev(I), Compare:=vbTextCompare)
End If

Next I
Next c
Set rg = Range("C1", Cells(Rows.Count, "C").End(xlUp))
For Each d In rg

For I = LBound(vLongName) To UBound(vLongName)

If InStr(1, d.Text, vLongName(I), vbTextCompare) > 0 Then
d(1, 2).Value = Replace(d.Text, vLongName(I), vAbbrev(I), Compare:=vbTextCompare)
End If

Next I
Next d
Set rg = Range("D1", Cells(Rows.Count, "D").End(xlUp))
For Each e In rg

For I = LBound(vLongName) To UBound(vLongName)

If InStr(1, e.Text, vLongName(I), vbTextCompare) > 0 Then
e(1, 2).Value = Replace(e.Text, vLongName(I), vAbbrev(I), Compare:=vbTextCompare)
End If

Next I
Next e
Set rg = Range("E1", Cells(Rows.Count, "E").End(xlUp))
For Each f In rg

For I = LBound(vLongName) To UBound(vLongName)

If InStr(1, f.Text, vLongName(I), vbTextCompare) > 0 Then
f(1, 2).Value = Replace(f.Text, vLongName(I), vAbbrev(I), Compare:=vbTextCompare)
End If

Next I
Next f
Set rg = Range("F1", Cells(Rows.Count, "F").End(xlUp))
For Each g In rg

For I = LBound(vLongName) To UBound(vLongName)

If InStr(1, g.Text, vLongName(I), vbTextCompare) > 0 Then
g(1, 2).Value = Replace(g.Text, vLongName(I), vAbbrev(I), Compare:=vbTextCompare)
End If

Next I
Next g
Set rg = Range("G1", Cells(Rows.Count, "G").End(xlUp))
For Each h In rg

For I = LBound(vLongName) To UBound(vLongName)

If InStr(1, h.Text, vLongName(I), vbTextCompare) > 0 Then
h(1, 2).Value = Replace(h.Text, vLongName(I), vAbbrev(I), Compare:=vbTextCompare)
End If

Next I
Next h
Set rg = Range("H1", Cells(Rows.Count, "H").End(xlUp))
For Each ii In rg

For I = LBound(vLongName) To UBound(vLongName)

If InStr(1, ii.Text, vLongName(I), vbTextCompare) > 0 Then
ii(1, 2).Value = Replace(ii.Text, vLongName(I), vAbbrev(I), Compare:=vbTextCompare)
End If

Next I
Next ii
Set rg = Range("I1", Cells(Rows.Count, "I").End(xlUp))
For Each j In rg

For I = LBound(vLongName) To UBound(vLongName)

If InStr(1, j.Text, vLongName(I), vbTextCompare) > 0 Then
j(1, 2).Value = Replace(j.Text, vLongName(I), vAbbrev(I), Compare:=vbTextCompare)
End If

Next I
Next j
Set rg = Range("J1", Cells(Rows.Count, "J").End(xlUp))
For Each k In rg

For I = LBound(vLongName) To UBound(vLongName)

If InStr(1, k.Text, vLongName(I), vbTextCompare) > 0 Then
k(1, 2).Value = Replace(k.Text, vLongName(I), vAbbrev(I), Compare:=vbTextCompare)
End If

Next I
Next k
Set rg = Range("K1", Cells(Rows.Count, "K").End(xlUp))
For Each l In rg

For I = LBound(vLongName) To UBound(vLongName)

If InStr(1, l.Text, vLongName(I), vbTextCompare) > 0 Then
l(1, 2).Value = Replace(l.Text, vLongName(I), vAbbrev(I), Compare:=vbTextCompare)
End If

Next I
Next l
Set rg = Range("L1", Cells(Rows.Count, "L").End(xlUp))
For Each m In rg

For I = LBound(vLongName) To UBound(vLongName)

If InStr(1, m.Text, vLongName(I), vbTextCompare) > 0 Then
m(1, 2).Value = Replace(m.Text, vLongName(I), vAbbrev(I), Compare:=vbTextCompare)
End If

Next I
Next m
Application.ScreenUpdating = True
End Sub

I hope this helps.
Jeff

hiker95 · Dec 19, 2014

gjdavis123,

Your latest workbook contains 2 visible sheets, and, 1 hidden sheet.

One last try:

Please supply another workbook with just one worksheet, with the actual worksheet name, that looks like the following (without the hidden columns), and, with no macros, and with a file extension of xlsx :

Excel 2007

A

B

C

M

N

O

P

1

Type (Optional)

Description (Required)

Keyword

Abbrev

2

Sport Swimming

sport

sprt

3

Gymnastics Speed Skating Cross Country Skiing

swimming

swimng

4

Short-Track Speed Skating Diving Cycling

country

contry

5

Ski Jumping Nordic Combined Athletics Table Tennis

jumping

jump

6

Synchronized Swimming Shooting Rowing Fencing Equestrian

single

sngl

7

Gymnastics

synchronized

sync

8

Short-Track Speed Skating

gymnastics

gym

9

Sport

side

1S

10

Gymnastics

combined

combi

11

Short-Track Speed Skating

Hybrid

hybrd

12

Ski Jumping

13

Synchronized Swimming

14

Ski Jumping Nordic Combined Athletics Table Tennis

15

Gymnastics

16

Short-Track Speed Skating

17

Ski Jumping

18

Ski Jumping Nordic Combined Athletics Table Tennis

19

Ski Jumping Nordic Combined Athletics Table Tennis

20

Short-Track Speed Skating

21

Sport

22

Gymnastics

23

Short-Track Speed Skating

24

Ski Jumping

25

Synchronized Swimming

26

Correct Name

gjdavis123 · Dec 20, 2014

Hello Hiker95,

I have uploaded a new workbook https://app.box.com/s/on00236lj73lcmsyguuu named Abbreviation with 1 worksheet named Abbrev. There should be no hidden columns and no macros and the file extension is xlsx. If there is a hidden sheet, I can't even tell that and I apologize.

I hope this is what you need. I appreciate your patience.

Regards,
Jeff

hiker95 said:
gjdavis123,

Your latest workbook contains 2 visible sheets, and, 1 hidden sheet.

One last try:

Please supply another workbook with just one worksheet, with the actual worksheet name, that looks like the following (without the hidden columns), and, with no macros, and with a file extension of xlsx :

Excel 2007

A B C M N O P
1 Type
(Optional) Description
(Required) Description
(Required) Description
(Required) Keyword Abbrev
2 Sport Swimming sport sprt
3 Gymnastics Speed Skating Cross Country Skiing swimming swimng
4 Short-Track Speed Skating Diving Cycling country contry
5 Ski Jumping Nordic Combined Athletics Table Tennis jumping jump
6 Synchronized Swimming Shooting Rowing Fencing Equestrian single sngl
7 Gymnastics synchronized sync
8 Short-Track Speed Skating gymnastics gym
9 Sport side 1S
10 Gymnastics combined combi
11 Short-Track Speed Skating Hybrid hybrd
12 Ski Jumping
13 Synchronized Swimming
14 Ski Jumping Nordic Combined Athletics Table Tennis
15 Gymnastics
16 Short-Track Speed Skating
17 Ski Jumping
18 Ski Jumping Nordic Combined Athletics Table Tennis
19 Ski Jumping Nordic Combined Athletics Table Tennis
20 Short-Track Speed Skating
21 Sport
22 Gymnastics
23 Short-Track Speed Skating
24 Ski Jumping
25 Synchronized Swimming
26

<colgroup><col style="width: 25pxpx"><col><col><col><col><col><col><col></colgroup><thead>
</thead><tbody>
</tbody>
Correct Name

hiker95 · Dec 20, 2014

gjdavis123,

Thanks for the new workbook.

Sample raw data in worksheet Abbrev (not all columns are shown to fit the MrExcel display area):

Excel 2007

B

C

N

O

1

Description(Required)

Keyword

Abbrev

2

Sport Swimming

sport

sprt

3

Gymnastics Speed Skating Cross Country Skiing

swimming

swimng

4

Short-Track Speed Skating Diving Cycling

country

contry

5

Ski Jumping Nordic Combined Athletics Table Tennis

jumping

jump

6

Synchronized Swimming Shooting Rowing Fencing Equestrian

single

sngl

7

Gymnastics

synchronized

sync

8

Short-Track Speed Skating

gymnastics

gym

9

Sport

side

1S

10

Gymnastics

combined

combi

11

Short-Track Speed Skating

Hybrid

hybrd

12

Ski Jumping

13

Synchronized Swimming

14

Ski Jumping Nordic Combined Athletics Table Tennis

15

Gymnastics

16

Short-Track Speed Skating

17

Ski Jumping

18

Ski Jumping Nordic Combined Athletics Table Tennis

19

Ski Jumping Nordic Combined Athletics Table Tennis

20

Short-Track Speed Skating

21

Sport

22

Gymnastics

23

Short-Track Speed Skating

24

Ski Jumping

25

Synchronized Swimming

26

Abbrev

After the macro:

Excel 2007

B

C

N

O

1

Description(Required)

Keyword

Abbrev

2

Sport Swimming

sprt swimng

sport

sprt

3

Gymnastics Speed Skating Cross Country Skiing

gym Speed Skating Cross contry Skiing

swimming

swimng

4

Short-Track Speed Skating Diving Cycling

country

contry

5

Ski Jumping Nordic Combined Athletics Table Tennis

Ski jump Nordic combi Athletics Table Tennis

jumping

jump

6

Synchronized Swimming Shooting Rowing Fencing Equestrian

sync swimng Shooting Rowing Fencing Equestrian

single

sngl

7

Gymnastics

gym

synchronized

sync

8

Short-Track Speed Skating

gymnastics

gym

9

Sport

sprt

side

1S

10

Gymnastics

gym

combined

combi

11

Short-Track Speed Skating

Hybrid

hybrd

12

Ski Jumping

Ski jump

13

Synchronized Swimming

sync swimng

14

Ski Jumping Nordic Combined Athletics Table Tennis

Ski jump Nordic combi Athletics Table Tennis

15

Gymnastics

gym

16

Short-Track Speed Skating

17

Ski Jumping

Ski jump

18

Ski Jumping Nordic Combined Athletics Table Tennis

Ski jump Nordic combi Athletics Table Tennis

19

Ski Jumping Nordic Combined Athletics Table Tennis

Ski jump Nordic combi Athletics Table Tennis

20

Short-Track Speed Skating

21

Sport

sprt

22

Gymnastics

gym

23

Short-Track Speed Skating

24

Ski Jumping

Ski jump

25

Synchronized Swimming

sync swimng

26

Abbrev

Please TEST this FIRST in a COPY of your workbook (always make a backup copy before trying new code, you never know what you might lose).

1. Copy the below code
2. Open your NEW workbook
3. Press the keys ALT + F11 to open the Visual Basic Editor
4. Press the keys ALT + I to activate the Insert menu
5. Press M to insert a Standard Module
6. Where the cursor is flashing, paste the code
7. Press the keys ALT + Q to exit the Editor, and return to Excel
8. To run the macro from Excel press ALT + F8 to display the Run Macro Dialog. Double Click the macro's name to Run it.

Code:

Option Compare Text
Sub ReplaceKeywordsWithAbbreviations()
' hiker95, 12/20/2014, ME825187
Dim lr As Long, c As Range
Dim s, i As Long, h As String, n As Range
Application.ScreenUpdating = False
With Sheets("Abbrev")
  lr = .Cells(Rows.Count, "C").End(xlUp).Row
  If lr > 1 Then .Range("C2:M" & lr).ClearContents
  For Each c In .Range("B2", .Range("B" & Rows.Count).End(xlUp))
    h = ""
    If InStr(c, " ") Then
      s = Split(c, " ")
      For i = LBound(s) To UBound(s)
        Set n = .Columns("N").Find(s(i), LookAt:=xlWhole)
        If n Is Nothing Then
          h = h & s(i) & " "
        ElseIf Not n Is Nothing Then
          h = h & .Range("O" & n.Row) & " "
        End If
      Next i
    Else
      Set n = .Columns("N").Find(c.Value, LookAt:=xlWhole)
      If n Is Nothing Then
        h = c.Value
      ElseIf Not n Is Nothing Then
        h = .Range("O" & n.Row)
      End If
    End If
    If Right(h, 1) = " " Then
      h = Left(h, Len(h) - 1)
    End If
    .Range("C" & c.Row & ":M" & c.Row).Value = h
  Next c
End With
Application.ScreenUpdating = True
End Sub

Before you use the macro with Excel 2007 or newer, save your workbook, Save As, a macro enabled workbook with the file extension .xlsm

Then run the ReplaceKeywordsWithAbbreviations macro.

gjdavis123 · Dec 22, 2014

Hello hiker95,

Thank you for the great code and quick response. It is much cleaner and lightning fast.

I have condensed it down more to reduce excessive columns and have set it up as a multiple find replace from list tool. Keywords are found by identifying " " in each cell. ie If you want to alter the word "short-hand it must be in keyword list as "short-hand", the word short and hand will not be individually changed when hyphenated. Replacements may be used to correct keyword spelling, replace keywords with an abbreviation or erase keywords from the cells, just leave replacement cell null.

This is a very powerful and dynamic script and I believe it will benefit a lot of users working with data.

I have uploaded a copy of FindReplaceKeywordsFromList-Working tool to https://app.box.com/s/tot5wcqekuq0jmg6wyb2. The screen image is at https://app.box.com/s/f8xymzxi29dxja5cyd4u

Also, thanks for a nice lesson,

Regards,
Jeff

Code:

Option Compare Text
Sub MultiFindReplaceFromList()
' hiker95, 12/20/2014, ME825187
' keywords are found by identifying " " in each cell, ie if you want to alter the word "short-hand"
' it  must be in keyword list as "short-hand", the word short and hand will not be individually when hyphenated
' replacements may be used to correct spelling or erase a keywords from the cells, just leave replacement cell null
'
Dim lr As Long, c As Range, MyCell As Range
Dim s, i As Long, h As String, n As Range
Application.ScreenUpdating = False
With Sheets("SetupFindReplace")
  lr = .Cells(Rows.Count, "B").End(xlUp).Row
  If lr > 1 Then .Range("B2:B" & lr).ClearContents
  For Each c In .Range("A2", .Range("A" & Rows.Count).End(xlUp))
    h = ""
    If InStr(c, " ") Then
      s = Split(c, " ")
      For i = LBound(s) To UBound(s)
        Set n = .Columns("C").Find(s(i), LookAt:=xlWhole)
        If n Is Nothing Then
          h = h & s(i) & " "
        ElseIf Not n Is Nothing Then
          h = h & .Range("D" & n.Row) & " "
        End If
      Next i
    Else
      Set n = .Columns("C").Find(c.Value, LookAt:=xlWhole)
      If n Is Nothing Then
        h = c.Value
      ElseIf Not n Is Nothing Then
        h = .Range("D" & n.Row)
      End If
    End If
    If Right(h, 1) = " " Then
      h = Left(h, Len(h) - 1)
    End If
    .Range("B" & c.Row & ":B" & c.Row).Value = h
  Next c
End With

' remove extra spaces after processing
On Error Resume Next
        
        For Each MyCell In Range("B2", Range("B" & Rows.Count).End(xlUp))
            MyCell.Value = Application.WorksheetFunction.Substitute(Trim(MyCell.Value), "     ", " ")
            MyCell.Value = Application.WorksheetFunction.Substitute(Trim(MyCell.Value), "    ", " ")
            MyCell.Value = Application.WorksheetFunction.Substitute(Trim(MyCell.Value), "   ", " ")
            MyCell.Value = Application.WorksheetFunction.Substitute(Trim(MyCell.Value), "  ", " ")
        Next
        
    On Error GoTo 0

Application.ScreenUpdating = True
End Sub

Sub MultiFindReplaceFromList()
' hiker95, 12/20/2014, ME825187
' keywords are found by identifying " " in each cell, ie if you want to alter the word "short-hand"
' it must be in keyword list as "short-hand", the word short and hand will not be individually changed when hyphenated
' replacements may be used to correct keyword spelling, replace keywords with an abbreviation or erase keywords from the cells, just leave replacement cell null
'
Dim lr As Long, c As Range, MyCell As Range
Dim s, i As Long, h As String, n As Range
Application.ScreenUpdating = False
With Sheets("SetupFindReplace")
lr = .Cells(Rows.Count, "B").End(xlUp).Row
If lr > 1 Then .Range("B2:B" & lr).ClearContents
For Each c In .Range("A2", .Range("A" & Rows.Count).End(xlUp))
h = ""
If InStr(c, " ") Then
s = Split(c, " ")
For i = LBound(s) To UBound(s)
Set n = .Columns("C").Find(s(i), LookAt:=xlWhole)
If n Is Nothing Then
h = h & s(i) & " "
ElseIf Not n Is Nothing Then
h = h & .Range("D" & n.Row) & " "
End If
Next i
Else
Set n = .Columns("C").Find(c.Value, LookAt:=xlWhole)
If n Is Nothing Then
h = c.Value
ElseIf Not n Is Nothing Then
h = .Range("D" & n.Row)
End If
End If
If Right(h, 1) = " " Then
h = Left(h, Len(h) - 1)
End If
.Range("B" & c.Row & ":B" & c.Row).Value = h
Next c
End With

' remove extra spaces after processing
On Error Resume Next

For Each MyCell In Range("B2", Range("B" & Rows.Count).End(xlUp))
MyCell.Value = Application.WorksheetFunction.Substitute(Trim(MyCell.Value), " ", " ")
MyCell.Value = Application.WorksheetFunction.Substitute(Trim(MyCell.Value), " ", " ")
MyCell.Value = Application.WorksheetFunction.Substitute(Trim(MyCell.Value), " ", " ")
MyCell.Value = Application.WorksheetFunction.Substitute(Trim(MyCell.Value), " ", " ")
Next

On Error GoTo 0

Application.ScreenUpdating = True
End Sub

hiker95 · Dec 22, 2014

gjdavis123,

Thank you for the great code and quick response. It is much cleaner and lightning fast.

Thanks for the feedback.

You are very welcome. Glad I could help.

I have uploaded a copy of FindReplaceKeywordsFromList-Working tool to https://app.box.com/s/tot5wcqekuq0jmg6wyb2. The screen image is at https://app.box.com/s/f8xymzxi29dxja5cyd4u

PNG image files are no good.

Please supply another workbook that contains one worksheet with the strings, and, the lookup tables, and, with column B manually formatted by you for the results you are looking for.

Multi Find Replace Keywords with Abbreviation from Range - How to loop through a changing range

gjdavis123

New Member

Excel Facts

hiker95

Well-known Member

gjdavis123

New Member

hiker95

Well-known Member

gjdavis123

New Member

hiker95

Well-known Member

gjdavis123

New Member

hiker95

Well-known Member

gjdavis123

New Member

hiker95

Well-known Member

Forum statistics

Share this page

	A	B	C	M	N	O
1	Type (Optional)	Description (Required)	Description (Required)	Description (Required)	Keyword	Abbrev
2		Sport Swimming			sport	sprt
3		Gymnastics Speed Skating Cross Country Skiing			swimming	swimng
4		Short-Track Speed Skating Diving Cycling			country	contry
5		Ski Jumping Nordic Combined Athletics Table Tennis			jumping	jump
6		Synchronized Swimming Shooting Rowing Fencing Equestrian			single	sngl
7		Gymnastics			synchronized	sync
8		Short-Track Speed Skating			gymnastics	gym
9		Sport			side	1S
10		Gymnastics			combined	combi
11		Short-Track Speed Skating			Hybrid	hybrd
12		Ski Jumping
13		Synchronized Swimming
14		Ski Jumping Nordic Combined Athletics Table Tennis
15		Gymnastics
16		Short-Track Speed Skating
17		Ski Jumping
18		Ski Jumping Nordic Combined Athletics Table Tennis
19		Ski Jumping Nordic Combined Athletics Table Tennis
20		Short-Track Speed Skating
21		Sport
22		Gymnastics
23		Short-Track Speed Skating
24		Ski Jumping
25		Synchronized Swimming
26

Multi Find Replace Keywords with Abbreviation from Range - How to loop through a changing range

New Member

Excel Facts

Well-known Member

New Member

Well-known Member

New Member

Well-known Member

New Member

Well-known Member

New Member

Well-known Member

Forum statistics

Share this page

We've detected that you are using an adblocker.

Which adblocker are you using?

Disable AdBlock

Disable AdBlock Plus

Disable uBlock Origin

Disable uBlock