VBA to find and replace and sort the valueswithin each cell

spartan .R
spartan .R used Ask the Experts™
on
i have a data to find and replace a values with other values in a column,ex "arjun + suresh + rajesh +marco" which has unique field to be replaced

ie: arjun should be replaced with 03 arjun, suresh should be replaced with 02 suresh, and rajesh with 08 rajesh, and marco with 06 marco.

after replacement the output will be "03 arjun +02 suresh +08 rajesh + 06 marco"

once we replace the values for the entire column in the same way mentioned above the each cell values should be sorted like ascending order with number "02 suresh+03 arjun +06 marco +08 rajesh"
Comment
Watch Question

Do more with

Expert Office
EXPERT OFFICE® is a registered trademark of EXPERTS EXCHANGE®
byundtMechanical Engineer
Most Valuable Expert 2013
Top Expert 2013

Commented:
I put the source text and replacement strings in a Table on worksheet Data. That way, you don't need to hard-code them in the macro.
Sub ReplaceAndSort()
Dim s As String, s1 As String, s2 As String, separator As String
Dim Replacements As Variant, v As Variant
Dim i As Long, j As Long, k As Long, n As Long, nRows As Long, nWords As Long
Dim cel As Range, rg As Range
Dim b As Boolean

separator = "|" 'This must be a character that will never be used in your data

Application.ScreenUpdating = False
Replacements = Worksheets("Data").ListObjects(1).DataBodyRange.Value
Set rg = Selection
Set rg = Intersect(rg, rg.Worksheet.UsedRange)

nRows = rg.Rows.Count
n = UBound(Replacements)

For j = 1 To n
    rg.Replace Replacements(j, 1), separator & " " & Replacements(j, 2), MatchCase:=False, LookAt:=xlPart
Next

For Each cel In rg.Cells
    v = Split(" " & cel.Value, separator)
    nWords = UBound(v)
    If nWords > 0 Then
        For i = 1 To nWords
            b = False
            For k = 1 To nWords
                If v(k - 1) > v(k) Then
                    s = v(k - 1)
                    v(k - 1) = v(k)
                    v(k) = s
                    b = True
                End If
            Next
            If b = False Then Exit For
        Next
        cel.Value = Application.Trim(Join(v, ""))
     End If
Next
End Sub

Open in new window

It is likely that I did not get the solution 100% as desired with this first iteration of the code. Please post a sample workbook with expected results to make any issuers clear.
byundtMechanical Engineer
Most Valuable Expert 2013
Top Expert 2013

Commented:
I made the following changes:
1. Created a two column Table in worksheet Replacements with the original text and its desired replacement
2. Added a button and instructions for how to use the macro to worksheet Data
3. Corrected some apparent typos in worksheet Data column A to make the test cases consistent with the desired results
4. Revised the macro to point to the two column Table
5. Revised the macro to separate each API with " + nn " where nn is the number from column B on worksheet Replacements
6. Stored the code in a regular Module, and saved the file with .xlsm file extension

Note that you must enable macros when you open the workbook.

Sub ReplaceAndSort()
Dim s As String, s1 As String, separator As String
Dim Replacements As Variant, v As Variant
Dim i As Long, j As Long, k As Long, n As Long, nRows As Long, nWords As Long
Dim cel As Range, rg As Range
Dim b As Boolean

separator = "|"     'This should be a character that never appears in the source text

Application.ScreenUpdating = False
Replacements = Worksheets("Replacements").ListObjects(1).DataBodyRange.Value
Set rg = Selection
Set rg = Intersect(rg, rg.Worksheet.UsedRange)

nRows = rg.Rows.Count
n = UBound(Replacements)

For j = 1 To n
    s1 = Replace(Replacements(j, 2), " ", Chr(160))
    rg.Replace Replacements(j, 1), separator & " " & s1, MatchCase:=False, LookAt:=xlPart
Next

For Each cel In rg.Cells
    v = Split(" " & cel.Value, separator)
    nWords = UBound(v)
    If nWords > 0 Then
        For i = 1 To nWords
            b = False
            For k = 1 To nWords
                If v(k - 1) > v(k) Then
                    s = v(k - 1)
                    v(k - 1) = v(k)
                    v(k) = s
                    b = True
                End If
            Next
            If b = False Then Exit For
        Next
        s = Application.Trim(Join(v, " "))
        s = Application.Trim(Replace(s, "+", " "))
        s = Replace(s, " ", " + ")
        s = Replace(s, Chr(160), " ")
        cel.Value = Application.Trim(s)
     End If
Next
End Sub

Open in new window

WheezerQ29165985.xlsm
byundtMechanical Engineer
Most Valuable Expert 2013
Top Expert 2013

Commented:
If you don't want spaces surrounding the + between the APIs, then change statement 41 in my code to:
        s = Replace(s, " ", "+")

Open in new window

Author

Commented:
Thanks a lot for the code could you please explain each and every line of the code and send me it would be very useful for me to workaround with it.

Author

Commented:
Also this is just for one column i have three similar column.I see in the code you have used listobjestcs(1) in the code to refer the table .If i want to use three other columns how do i refer it after creating a table for it.Thanks in advance
byundtMechanical Engineer
Most Valuable Expert 2013
Top Expert 2013

Commented:
byundtMechanical Engineer
Most Valuable Expert 2013
Top Expert 2013

Commented:
i have three similar column
If you mean that you have three columns that need to be converted, run the macro three times. Make sure you select the cells to be converted before running the macro.

ListObjects(1) means the first Table added to worksheet Replacements. I'm not expecting you to have more than one set of find and replacement texts. If you do, I wish you had let me know earlier, as I would have planned the code differently.

When you post a question in a help forum, it is best if you include a sample workbook showing the actual layout and full complexity. I comment statements I expect you may need to change. If a statement is uncommented, you change it at your own risk. Changing the subscript in ListObjects(1) is a good example of something that will cause problems if you don't understand VBA well enough to write code from scratch.

Author

Commented:
Am very sorry for that because i don't want to share the file because its sensitive.Attached the file with three columns which has to be replaced and sorted .Ignore if there are no values for replacement.
Relacement.xlsx
byundtMechanical Engineer
Most Valuable Expert 2013
Top Expert 2013

Commented:
Can I be certain that there are no spaces in the text to be converted, and that + always separates different terms?

Author

Commented:
Yes that + will always separate different terms.yeah as of now there are no spaces i have checked several workbooks,in caes lets say tmrw for a two or three cells has spaces . please consider tat part as well . thanks in advance.i have checked your code and it works like champ.you are superb dude.
byundtMechanical Engineer
Most Valuable Expert 2013
Top Expert 2013

Commented:
I rewrote the code to suit the layout of the data in your latest workbook. It will not work with the earlier workbooks! The new macro is called Master; it calls sub ReplaceAndSort and function CrossRef.

Please run your tests on worksheet Test, and copy data from Data to Test each time you want to repeat the test. When you are 100% happy with the results of the macro, you may delete worksheet Test and run the macro on worksheet Data.

You do not need to preselect any cells--the macro assumes your data starts in row 2 and continues until the bottom of your data. Likewise, the macro assumes that you have two single column lists of coded tests and APIs in worksheet Replacements. Those single column lists start in row 4.

You will notice that most of the tests and APIs are coded correctly by the macro. If there are failures, it is because of typos either in the test data or in the Replacement lists. You must correct them, and then repeat the test.

Because I had to do a major rewrite, I started with the penultimate version of the code rather than one with all the Comments.

If the code is working for you, don't forget to close the question by selecting an Answer.
Sub Master()
Dim rg As Range, Replacements_1 As Range, Replacements_2 As Range
Dim Replace1 As Variant, Replace2 As Variant
Application.ScreenUpdating = False
With ActiveSheet
    Set rg = .Range("A2")   'First cell with data
    Set rg = Range(rg, .Cells(.Rows.Count, rg.Column).End(xlUp))
    Set rg = rg.Resize(rg.Rows.Count, 3)
End With

With Worksheets("Replacements")
    Set Replacements_1 = .Range("A4")   'First cell with data
    Set Replacements_1 = Range(Replacements_1, .Cells(.Rows.Count, Replacements_1.Column).End(xlUp))
    Replace1 = CrossRef(Replacements_1)

    Set Replacements_2 = .Range("C4")   'First cell with data
    Set Replacements_2 = Range(Replacements_2, .Cells(.Rows.Count, Replacements_2.Column).End(xlUp))
    Replace2 = CrossRef(Replacements_2)
End With

ReplaceAndSort rg.Columns(1), Replace1
ReplaceAndSort rg.Columns(2), Replace2
ReplaceAndSort rg.Columns(3), Replace2
End Sub

Function CrossRef(rg As Range) As Variant
'Returns a two column array from a single column range. The first column is the raw text, and the second are the desired replacements
Dim i As Long, n As Long
Dim v As Variant
n = rg.Rows.Count
v = rg.Resize(n, 2).Value
For i = 1 To n
    v(i, 2) = v(i, 1)
    v(i, 1) = Split(v(i, 1), " ")(1)
Next
CrossRef = v
End Function

Sub ReplaceAndSort(rg As Range, Replacements As Variant)
Dim s As String, s1 As String, separator As String
Dim v As Variant, vv As Variant
Dim i As Long, ii As Long, j As Long, k As Long, n As Long, nRows As Long, nWords As Long
Dim cel As Range
Dim b As Boolean

separator = "+"

nRows = rg.Rows.Count
n = UBound(Replacements)
vv = rg.Value

For k = 1 To nRows
    If vv(k, 1) <> "" Then
        v = Split(vv(k, 1), separator)
        nWords = UBound(v)
        For i = 0 To nWords
            For j = 1 To n
                If v(i) = Replacements(j, 1) Then v(i) = Replacements(j, 2)
            Next
        Next
        
        If nWords > 0 Then
            For ii = 1 To nWords
                b = False
                For i = 1 To nWords
                    If v(i - 1) > v(i) Then
                        s = v(i - 1)
                        v(i - 1) = v(i)
                        v(i) = s
                        b = True
                    End If
                Next
                If b = False Then Exit For
            Next
            
            vv(k, 1) = Join(v, separator)
         Else
            vv(k, 1) = v(0)
         End If
     End If
Next
rg.Value = vv
End Sub

Open in new window

Replacement.xlsm

Author

Commented:
Thanks alot buddy Sorry for an late reply.the code works like an champ.Still i have two more questions.this very small you can explain me in words if its not complicated.1.Now the replacement columns are in 1 ,2,3  lets say if its in 5,6,7 how do i change it accordingly.one i should change in master columns(5),columns(6),columns(7). but in replacement sub procedure am not sure where to change.2.i want to highlight if the value doesnt get replaced with values.So that it will be easier for me to QC. thank you
byundtMechanical Engineer
Most Valuable Expert 2013
Top Expert 2013

Commented:
All the changes you requested but one are made in the Master sub.

To change the location of the columns with text that you need to code with numbers, change the snippet below. The snippet assumes there are 3 successive columns, with data starting in cell A1.
With ActiveSheet
    Set rg = .Range("A2")   'First cell with data
    Set rg = Range(rg, .Cells(.Rows.Count, rg.Column).End(xlUp))
    Set rg = rg.Resize(rg.Rows.Count, 3)
End With

Open in new window


To change the location of the replacement text, change the snippet below. It assumes there are only two tables, one starting in cell A4 and the other in C4.
With Worksheets("Replacements")
    Set Replacements_1 = .Range("A4")   'First cell with data
    Set Replacements_1 = Range(Replacements_1, .Cells(.Rows.Count, Replacements_1.Column).End(xlUp))
    Replace1 = CrossRef(Replacements_1)

    Set Replacements_2 = .Range("C4")   'First cell with data
    Set Replacements_2 = Range(Replacements_2, .Cells(.Rows.Count, Replacements_2.Column).End(xlUp))
    Replace2 = CrossRef(Replacements_2)
End With

Open in new window


To change which replacement table goes with which column of source data, you change the snippet below. As written, the first source column and first replacement table go together, as do the second and third source column and second replacement table.
ReplaceAndSort rg.Columns(1), Replace1
ReplaceAndSort rg.Columns(2), Replace2
ReplaceAndSort rg.Columns(3), Replace2

Open in new window

i want to highlight if the value doesn't get replaced with values.
That would require a complete rewrite. How about if I put five asterisks in front of the text that didn't get replaced? See attached workbook.

You didn't ask, but I anticipate a problem with handling common typos like "UMECLIDIMIUM" vs. "08 UMECLIDINIUM". There was a reason why I twice suggested a two column list with the source word in the first column and the replacement in the second. You overrode that suggestion twice with a single column list. With a two column list, you could have had both "UMECLIDIMIUM" and "UMECLIDINIUM" in the first column with "08 UMECLIDINIUM" in the second. WIth a single column list, you must police your raw data to eliminate such typos.

A common workaround for ending errors like "BUDESONIDE" vs. "BUDESONID" is to match the root of the replacement text against the source. So "BUDESONID" would match both "BUDESONID" and "BUDESONIDE." This approach would be contra-indicated if you had replacement text in longer and shorter forms such as "01 LABA" and "02 LABA MISC." I didn't see any such problems, and so implemented the change.
Replacement.xlsm

Author

Commented:
Thanks alot

Author

Commented:
Hi Need an additional help on the same.once the cells value sorted by numbers I want to remove the numbers .Could you please add an additional code for the same please.
byundtMechanical Engineer
Most Valuable Expert 2013
Top Expert 2013

Commented:
I added a call to the following new sub to Master. After sorting, the two-digit numbers will be removed.
Sub DeleteCodes(rg As Range)
Static RegEx As Object
Dim oMatches As Object
Dim v As Variant
Dim i As Long, j As Long, nCols As Long, nRows As Long

v = rg.Value
nRows = rg.Rows.Count
nCols = rg.Columns.Count

If RegEx Is Nothing Then Set RegEx = CreateObject("VBScript.RegExp")
With RegEx
    .Global = True
    .Pattern = "\d{2}"

    For i = 1 To nRows
        For j = 1 To nCols
            If .test(v(i, j)) Then v(i, j) = .Replace(v(i, j), "")
        Next
    Next
End With

rg.Value = v
End Sub

Open in new window

Replacement.xlsm

Author

Commented:
Hi Thanks,

After doing quality checks with the automation i found one bug and it was sent from my manager if you can notice row a566:a571 its FIXED ICS\LABA after replacement it should be 05 FIXED ICS\LABA ,but its getting replaced as 04 FIXED LAMA\LABA.Can you fix it i just noticed only this  bug,there  are chances to be many .also can we go to previous methodology like creating three tables with columns"find this" and "replace ".
byundtMechanical Engineer
Most Valuable Expert 2013
Top Expert 2013

Commented:
The problem with A566:A571 was caused by a bug in my code. I fixed it with the For i = 1 To n  block in the snippet below.
Function CrossRef(rg As Range) As Variant
'Returns a two column array from a single column range. The first column is the raw text, and the second are the desired replacements
Dim i As Long, n As Long
Dim v As Variant
n = rg.Rows.Count
v = rg.Resize(n, 2).Value
For i = 1 To n
    v(i, 2) = UCase(v(i, 1))
    v(i, 1) = Mid(v(i, 1), InStr(1, v(i, 1), " ") + 1)
Next
CrossRef = v
End Function

Open in new window


Good decision on your part though about changing to a two column list for "find this" and "replace". Please put the "find this" columns in A and C, and the "replace" columns in B and D. I did this in the attached workbook.

With that change, I commented out the For i = 1 To n block in the above snippet. No other change to the code was needed.

You will still find a number of items with ***** prefixing the text after the macro runs. I suspect those are all either items missing in the Replacements worksheet or ones with mispellings. If you put both correct and misspelled versions in "find this" columns A and C (each on a separate row), the code will assign them to the correct "replace" value. No code changes are required for that.
Replacement.xlsm

Author

Commented:
In the above attached file when i comment delete codes and run the macro the replacement and sorting doesn't happen for all the rows.Can i know why please.replacement and sorting  has happened only for rows 572 :579.
Mechanical Engineer
Most Valuable Expert 2013
Top Expert 2013
Commented:
Oops. My goof on that one. I posted a test version, rather than the one you should be using.
Replacement.xlsm

Do more with

Expert Office
Submit tech questions to Ask the Experts™ at any time to receive solutions, advice, and new ideas from leading industry professionals.

Start 7-Day Free Trial