Find and Replace Multiple values in Excel

Hi friends,

I want run a find and replace on multiple values from work files .

I have 2 Excel files,files from the first worksheet contains old Room number and new room number as follows
Column-A Column-B
Old Room tag New room Tag

-1.712 B-R121
-1.651 C-F677
- - - - around 500 values continues in columns as mentioned above.

In 2nd files contain multiple worksheet (50 worksheet),Above mentioned old room taggs are mentioned in the 50 worksheets which need to be repalce as new room tags. i am struggling to replace those taggs.Please advice the macro code which will be easy me to complete my task.

Hello dawoodmpm,


Are the room numbers on the other worksheets in specific columns?


If the columns have headers then which headers are the room numbers under?

Thanks for your quick response Laith

Yes ,The Room tags are located in the different worksheet named "ROOM TAGS ".In column A Contains Old Room tags with header named "OLD ROOM TAGS", Similarly Colum B having New room Tags with Header named "NEW ROOM TAGS"

Attachment 23416

Hello dawoodmpm,

Are the other worksheets the same as "ROOM TAGS" ?

Hi Leith,

Thanks for your kind reply.

Are the other worksheets the same as "ROOM TAGS" ?

Yes. Same room tags are available in the different work sheets.

(I just want to replace the old room tags with the present new room tags)

For your easy understanding.The snapshot is provided with old room tags highlighted in red color text need to be replaced as new room tags.

Enlarged View:

Attachment 23418
Full Page View:
Attachment 23417

It usually works better to attach a sample workbook with all pertenent data and the macros (if any) instead of screen shots, especially since someone can't even copy/paste data from a screen shot to generate test data to try and help

Hello dawoodmpm.

This is has been tested using the examples you provided. However, I cannot guarantee it will work with your actual data since it has been tested on such a limited data set.

Run this macro on a copy of your workbook before installing it in your main workbook. Let me know what your results are.

Code:

---

' Thread:  http://www.vbaexpress.com/forum/showthread.php?64251-Find-and-Replace-Multiple-values-in-Excel
' Poster:  dawoodmpm
' Written:  December 16, 2018
' Author:  Leith Ross


Sub Macro1()


    Dim Cell    As Range
    Dim Data    As Variant
    Dim Index  As Long
    Dim Matches As Object
    Dim NewTag  As Variant
    Dim OldTag  As Variant
    Dim RegExp  As Object
    Dim Rng    As Range
    Dim RngBeg  As Range
    Dim RngEnd  As Range
    Dim Tag    As Variant
    Dim Tags    As Object
    Dim Text    As String
    Dim Wks    As Worksheet
   
        Set Wks = ThisWorkbook.Worksheets("Room Tags")
       
        Set RngBeg = Wks.Range("A2")
        Set RngEnd = Wks.Cells(Rows.Count, RngBeg.Column).End(xlUp)
        Set Rng = Wks.Range(RngBeg, RngEnd)
       
        Set RegExp = CreateObject("VBScript.RegExp")
            RegExp.Global = True
            RegExp.MultiLine = True
            RegExp.Pattern = "\(-?\d+\.\w+\)"
           
        Set Tags = CreateObject("Scripting.Dictionary")
            Tags.CompareMode = vbTextCompare
           
            For Each Cell In Rng
                OldTag = Trim(Cell)
                NewTag = Trim(Cell.Offset(0, 1))
               
                If OldTag <> "" Then
                    If Not Tags.Exists(OldTag) Then
                        Tags.Add OldTag, NewTag
                    End If
                End If
            Next Cell
           
        For Each Wks In ThisWorkbook.Worksheets
            If UCase(Wks.Name) <> "ROOM TAGS" Then
                Set RngBeg = Wks.Range("H11")
                Set RngEnd = Wks.Cells(Rows.Count, RngBeg.Column).End(xlUp)
                Set Rng = Wks.Range(RngBeg, RngEnd)
               
                If RngEnd.Row >= RngBeg.Row Then
                    If Rng.Cells.Count = 1 Then
                        ReDim Data(1, 1)
                        Data(1, 1) = Rng.Value
                    Else
                        Data = Rng.Value
                    End If
                       
                    For Index = 1 To UBound(Data, 1)
                        Text = Data(Index, 1)
                        Set Matches = RegExp.Execute(Text)
                            For Each OldTag In Matches
                                NewTag = Tags(OldTag)
                                Text = Replace(Text, OldTag, NewTag, OldTag.FirstIndex + 1, 1, vbTextCompare)
                            Next OldTag
                        Data(Index, 1) = Text
                    Next Index
                   
                    Rng.Value = Data
                End If
            End If
        Next Wks
       
End Sub

---

Hi Leith,

I have tried with above VBA code.It is totally deleting all the data in this excel file wherever room number consists.So i have attached my excel file with this thread for your easy reference.Please check.

Hello dawoodmpm,

Yeah I found a couple odd things in the macro's behaviour. I just finished making the changes and test it. This will work correctly for the sample.

Thanks for the workbook. I will try it on its data.

Code:

---

Sub Macro2()


    Dim Cell    As Range
    Dim cnt    As Long
    Dim Data    As Variant
    Dim Index  As Long
    Dim Matches As Object
    Dim NewTag  As Variant
    Dim OldTag  As Variant
    Dim RegExp  As Object
    Dim Rng    As Range
    Dim RngBeg  As Range
    Dim RngEnd  As Range
    Dim Tag    As Variant
    Dim Tags    As Object
    Dim Text    As String
    Dim Wks    As Worksheet
   
        Set Wks = ThisWorkbook.Worksheets("Room Tags")
       
        Set RngBeg = Wks.Range("A2")
        Set RngEnd = Wks.Cells(Rows.Count, RngBeg.Column).End(xlUp)
        Set Rng = Wks.Range(RngBeg, RngEnd)
       
        Set RegExp = CreateObject("VBScript.RegExp")
            RegExp.Global = True
            RegExp.MultiLine = True
            RegExp.Pattern = "(?:\()(-?\d+\.\w+)(?:\))"
           
        Set Tags = CreateObject("Scripting.Dictionary")
            Tags.CompareMode = vbTextCompare
           
            For Each Cell In Rng
                OldTag = Trim(Cell)
                NewTag = Trim(Cell.Offset(0, 1))
               
                If OldTag <> "" Then
                    If Not Tags.Exists(OldTag) Then
                        Tags.Add OldTag, NewTag
                    End If
                End If
            Next Cell
           
        For Each Wks In ThisWorkbook.Worksheets
            If UCase(Wks.Name) <> "ROOM TAGS" Then
                Set RngBeg = Wks.Range("H11")
                Set RngEnd = Wks.Cells(Rows.Count, RngBeg.Column).End(xlUp)
                Set Rng = Wks.Range(RngBeg, RngEnd)
               
                If RngEnd.Row >= RngBeg.Row Then
                    If Rng.Cells.Count = 1 Then
                        ReDim Data(1, 1)
                        Data(1, 1) = Rng.Value
                    Else
                        Data = Rng.Value
                    End If
                       
                    For Index = 1 To UBound(Data, 1)
                        Text = Data(Index, 1)
                        Set Matches = RegExp.Execute(Text)
                       
                            For cnt = 0 To Matches.Count - 1
                                OldTag = Matches(cnt).SubMatches(0)
                                NewTag = Tags(OldTag)
                               
                                If NewTag <> "" Then
                                    Text = Left(Text, Matches(cnt).FirstIndex + 1 - cnt) & NewTag _
                                        & Right(Text, Len(Text) - (Matches(cnt).FirstIndex + Matches(cnt).Length - 1 - cnt))
                                End If
                            Next cnt
                       
                        Data(Index, 1) = Text
                    Next Index
                   
                    If Rng.Cells.Count = 1 Then
                        Rng.Value = Data(1, 1)
                    Else
                        Rng.Value = Data
                    End If
                End If
            End If
        Next Wks
       
End Sub

---

Hello dawoodmpm,

Okay, third time is the charm. I used this macro in the workbook you attached. It appears to me that it is working. Of course, you know better than anyone if it is. Use this one...

Code:

---

' Thread:  http://www.vbaexpress.com/forum/showthread.php?64251-Find-and-Replace-Multiple-values-in-Excel
' Poster:  dawoodmpm
' Written:  December 16, 2018
' Author:  Leith Ross


Sub Macro3()


    Dim Cell    As Range
    Dim cnt    As Long
    Dim Data    As Variant
    Dim Index  As Long
    Dim Matches As Object
    Dim NewTag  As Variant
    Dim OldTag  As Variant
    Dim RegExp  As Object
    Dim Rng    As Range
    Dim RngBeg  As Range
    Dim RngEnd  As Range
    Dim Tag    As Variant
    Dim Tags    As Object
    Dim Text    As String
    Dim Wks    As Worksheet
   
        Set Wks = ThisWorkbook.Worksheets("Room Tags")
       
        Set RngBeg = Wks.Range("A2")
        Set RngEnd = Wks.Cells(Rows.Count, RngBeg.Column).End(xlUp)
        Set Rng = Wks.Range(RngBeg, RngEnd)
       
        Set RegExp = CreateObject("VBScript.RegExp")
            RegExp.Global = True
            RegExp.MultiLine = True
            RegExp.Pattern = "(?:\()(-?\d+\.\w+)(?:\))"
           
        Set Tags = CreateObject("Scripting.Dictionary")
            Tags.CompareMode = vbTextCompare
           
            For Each Cell In Rng
                OldTag = Trim(Cell)
                NewTag = Trim(Cell.Offset(0, 1))
               
                If OldTag <> "" Then
                    If Not Tags.Exists(OldTag) Then
                        Tags.Add OldTag, NewTag
                    End If
                End If
            Next Cell
           
        For Each Wks In ThisWorkbook.Worksheets
            Select Case UCase(Wks.Name)
                Case Is = "ROOM TAGS", "WORK FILE", "MAIN DB DATA"
                    ' Skip these Worksheets
                Case Else
                    Set RngBeg = Wks.Range("H11")
                    Set RngEnd = Wks.Cells(Rows.Count, RngBeg.Column).End(xlUp)
                    Set Rng = Wks.Range(RngBeg, RngEnd)
               
                    If RngEnd.Row >= RngBeg.Row Then
                        If Rng.Cells.Count = 1 Then
                            ReDim Data(1, 1)
                            Data(1, 1) = Rng.Value
                        Else
                            Data = Rng.Value
                        End If
                       
                        For Index = 1 To UBound(Data, 1)
                            Text = Data(Index, 1)
                            Set Matches = RegExp.Execute(Text)
                       
                            For cnt = 0 To Matches.Count - 1
                                OldTag = Matches(cnt).SubMatches(0)
                                NewTag = Tags(OldTag)
                               
                                If NewTag <> "" Then
                                    Text = Left(Text, Matches(cnt).FirstIndex + 1 - cnt) & NewTag _
                                        & Right(Text, Len(Text) - (Matches(cnt).FirstIndex + Matches(cnt).Length - 1 - cnt))
                                End If
                            Next cnt
                       
                            Data(Index, 1) = Text
                        Next Index
                   
                    If Rng.Cells.Count = 1 Then
                        Rng.Value = Data(1, 1)
                    Else
                        Rng.Value = Data
                    End If
                End If
            End Select
        Next Wks
       
End Sub

---

Its really works well.Thank you so much for your kind support at right time.

Sincerely

Dawood Abdul Kader

Hello dawoodmpm,

You're welcome. If you have any questions about how the macro works, just ask me.

Since this seemed to be a one time macro and performance most likely wasn't an issue, I wasn't making my offering nearly as elegant as Leith's


This is a simple looping version that I figured I might as well post since I almost had it finished

Code:

---

Option Explicit


Sub UpdateRooms()

    Dim rRooms As Range, rRoom As Range
    Dim ws As Worksheet
   
    Set rRooms = Worksheets("ROOM TAGS").Cells(1, 1).CurrentRegion
   
    Application.ScreenUpdating = False
   
    For Each ws In ThisWorkbook.Worksheets
           
        Select Case ws.Name
            Case "ROOM TAGS", "work file", "MAIN DB DATA"
           
            Case Else
                For Each rRoom In rRooms.Rows
                    Application.StatusBar = "Worksheet = " & ws.Name & " New Room row number " & rRoom.Row
                    Call Range(ws.UsedRange, ws.Columns(8)).Replace(rRoom.Cells(1).Value, rRoom.Cells(2).Value, xlPart)
                Next
        End Select
    Next
   
    Application.StatusBar = False
    Application.ScreenUpdating = True
   
End Sub

---

Hi Mr.Paul,

Hope you are doing good and Thanks for your Support.

I really appreciate both of you(Leith &Paul) for your efforts to spending your valuable time on unknown face.

This macro code is also really nice and very simple,but values are changing in first worksheet of the excel file and also i have received Pop Up error msge like"Run Time error -1004",once the value changed.

Your sincerely

Dawood

Hmmmm - I took a look even if you don't need it

By making the macro simple, there's less to go wrong and less to debug

I ran the macro on the attached and it seems to replace rooms and did not get a 1004 error

I'm using Excel 2016

Hi Mr.Paul,

Hope you are doing good.

I have tried with your Macro.It works well.Some room names are not changing due to mismatches.So I am facing problem to identify the changed room name and tags.

Is it possible to make the letters bolt whichever had changed in this worksheet?Please help

sincerely,

Dawood

One new line, and one changed line

The Bold version didn't show up too well, so I tried Green shading

Code:

---

Sub UpdateRooms()
    Dim rRooms As Range, rRoom As Range
    Dim ws As Worksheet
   
    Set rRooms = Worksheets("ROOM TAGS").Cells(1, 1).CurrentRegion
   
    Application.ScreenUpdating = False
   
    For Each ws In ThisWorkbook.Worksheets
           
        Select Case ws.Name
            Case "ROOM TAGS", "work file", "MAIN DB DATA"
           
            Case Else
                For Each rRoom In rRooms.Rows
                    Application.StatusBar = "Worksheet = " & ws.Name & " New Room row number " & rRoom.Row
                   
'                    Application.ReplaceFormat.Font.Bold = True        '  new line, but didn't show very well
                    Application.ReplaceFormat.Interior.Color = vbGreen '  different new line, shows better
                    Call Range(ws.UsedRange, ws.Columns(8)).Replace(rRoom.Cells(1).Value, rRoom.Cells(2).Value, xlPart, , , , , True)  '  changed
                   
                   
                Next
        End Select
    Next
   
    Application.StatusBar = False
    Application.ScreenUpdating = True
   
End Sub

---