Replace a character string with other characters in column "K"

H

harzer

Board Regular
Joined
Dec 15, 2021
Messages
153
Office Version
  1. 2016
Platform
  1. Windows
Hello everyone,
I have a code which should normally replace certain characters (in column "K") with other characters, but it is impossible to make it work, where is the problem?
Unless I'm mistaken, the correct result is in column "N".
Thank you for your propositions.


VBA Code: 
Sub remplacer_Chaines()

    Dim ws As Worksheet
    Dim arrReplace As Variant
    Dim strReplacement As String
    Dim i As Long

    Set ws = ThisWorkbook.Sheets("Parents")

    arrReplace = Array(, "elevé", "Hty27", "hty27", "Hwa96", "hwa96", "cage")
    For i = LBound(arrReplace) To UBound(arrReplace)

        Select Case arrReplace(i)
            Case "elevé"
                strReplacement = "Elevé"
            Case "Hty27", "hty27"
                strReplacement = "HTY27"
            Case "Hwa96", "hwa96"
                strReplacement = "HWA96"
            Case "cage"
                strReplacement = "Cage"

        End Select

        ws.Columns("K").Replace What:=arrReplace(i), Replacement:=strReplacement, LookAt:=xlWhole, SearchOrder _
            :=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False

    Next i

End Sub

Code_Test.xlsm
ABCDEFGHIJKLMN
1Jeune+N46A1:N44PèreMèreEleveurÂgeVolièreCageNé(e)ToursCouleurElevageConsanguinitéancêtre principaleRésultat
2**********elevé/hty27-017/23 cage 12**Elevé/HTY27-017/23 Cage 12
3**********elevé/Hty27-017/23 cage 12X**Elevé/HTY27-017/23 Cage 12X
4**********elevé/Hty27-017/23 Cage 12 X**Elevé/HTY27-017/23 Cage 12 X
5**********elevé/Hty27-017/23 cage 12**Elevé/HTY27-017/23 Cage 12
6**********elevé/Hty27-023/23 cage 8**Elevé/HTY27-023/23 Cage 8
7**********elevé/hty27-023/23 cage 9**Elevé/HTY27-023/23 Cage 9
8**********elevé/hty27-023/23 cage 10**Elevé/HTY27-023/23 Cage 10
9**********elevé/hty27-023/23 Cage 11**Elevé/HTY27-023/23 Cage 11
10**********elevé/hwa96-045/22 cage 13**Elevé/HWA96-045/22 Cage 13
11**********elevé/Hty27-015/23 cage 11**Elevé/HTY27-015/23 Cage 11
12**********elevé/Hwa96-045/22 cage 14**Elevé/HWA96-045/22 Cage 14
13**********elevé/Hty27-019/23 Cage 6**Elevé/HTY27-019/23 Cage 6
14**********elevé/hty27-015/23 cage 11**Elevé/HTY27-015/23 Cage 11
15**********elevé/hty27-015/23 cage 11**Elevé/HTY27-015/23 Cage 11
16**********elevé/hty27-015/23 cage 11**Elevé/HTY27-015/23 Cage 11
17**********elevé/hty27-038/22 Cage 10 X**Elevé/HTY27-038/22 Cage 10 X
18**********elevé/hty27-038/22 cage 10**Elevé/HTY27-038/22 Cage 10
19**********elevé/Hty27-010/23 cage 5**Elevé/HTY27-010/23 Cage 5
20**********elevé/Hwa96-034/21 cage 2**Elevé/HWA96-034/21 Cage 2
21**********elevé/Hty27-038/22 cage 10**Elevé/HTY27-038/22 Cage 10
22**********elevé/Hwa96-010/21 cage 9**Elevé/HWA96-010/21 Cage 9
23**********elevé/hwa96-010/21 Cage 9**Elevé/HWA96-010/21 Cage 9
24**********elevé/hwa96-010/21 cage 9**Elevé/HWA96-010/21 Cage 9
25**********elevé/hwa96-034/21 cage 2**Elevé/HWA96-034/21 Cage 2
26**********elevé/hwa96-010/21 cage 9**Elevé/HWA96-010/21 Cage 9
27**********elevé/hty27-019/23 cage 6**Elevé/HTY27-019/23 Cage 6
28**********elevé/Hty27-010/23 cage 5**Elevé/HTY27-010/23 Cage 5
29**********elevé/Hwa96-02723 cage 14**Elevé/HWA96-02723 Cage 14
30**********elevé/Hty27-010/23 cage 5**Elevé/HTY27-010/23 Cage 5
31**********elevé/Hwa96-010/21 cage 9**Elevé/HWA96-010/21 Cage 9
32**********elevé/Hwa96-027/23 cage 14**Elevé/HWA96-027/23 Cage 14
33**********elevé/Hwa96-027/23 cage 14**Elevé/HWA96-027/23 Cage 14
34**********elevé/Hty27-026/22 cage 1**Elevé/HTY27-026/22 Cage 1
35**********elevé/Hty27-026/22 cage 1**Elevé/HTY27-026/22 Cage 1
36**********elevé/hty27-026/22 cage 1**Elevé/HTY27-026/22 Cage 1
37**********elevé/hty27-026/22 cage 1**Elevé/HTY27-026/22 Cage 1
38**********elevé/hty27-020/23 cage 7**Elevé/HTY27-020/23 Cage 7
39**********elevé/hty27-020/23 cage 7**Elevé/HTY27-020/23 Cage 7
40**********elevé/hty27-020/23 cage 7**Elevé/HTY27-020/23 Cage 7
41**********elevé/hty27-020/23 cage 7**Elevé/HTY27-020/23 Cage 7
42**********elevé/hty27-037/22 cage 3**Elevé/HTY27-037/22 Cage 3
43**********elevé/hty27-037/22 cage 3**Elevé/HTY27-037/22 Cage 3
44**********elevé/hty27-037/22 cage 3**Elevé/HTY27-037/22 Cage 3
Parents
 

Excel Facts

Waterfall charts in Excel?
Office 365 customers have access to Waterfall charts since late 2016. They were added to Excel 2019.
Sort by date Sort by votes
How about this. It's your code with a correction to "LookAt=xlWhole to xlPart. Also I removed a comma at the beginning of your array.

VBA Code: 
Sub remplacer_Chaines()

    Dim ws As Worksheet
    Dim arrReplace As Variant
    Dim strReplacement As String
    Dim i As Long

    Set ws = ThisWorkbook.Sheets("Parents")

    arrReplace = Array("elevé", "Hty27", "hty27", "Hwa96", "hwa96", "cage")
    For i = LBound(arrReplace) To UBound(arrReplace)

        Select Case arrReplace(i)
            Case "elevé"
                strReplacement = "Elevé"
            Case "Hty27", "hty27"
                strReplacement = "HTY27"
            Case "Hwa96", "hwa96"
                strReplacement = "HWA96"
            Case "cage"
                strReplacement = "Cage"

        End Select

        ws.Columns("K").Replace What:=arrReplace(i), Replacement:=strReplacement, LookAt:=xlPart, SearchOrder _
            :=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False

    Next i

End Sub
 
Upvote 0
Hello Igold,
Thank you for your feedback as well as the modification made to the code so that it can work.
The proposed solution satisfies me and gives me the desired result. It's perfect.
Greetings.
 
Upvote 0
You're welcome, I was happy to help. Thanks for the kind feedback!
 
Upvote 0
Another possibility.
Code: 
Sub Maybe_So()
Dim c As Range
    For Each c In Range("K2:K" & Cells(Rows.Count, 11).End(xlUp).Row)
        c.Value = Replace(Replace(Replace(Replace(Replace(Replace(c.Value, "elevé", "Elevé"), "Hty27", "HTY27"), "hty27", "HTY27"), "Hwa96", "HWA96"), "hwa96", "HWA96"), "cage", "Cage")
Next c
End Sub
 
Upvote 0
If it has to go into Column N, change it to so.
Code: 
c.Offset(, 3).Value = Replace(Replace(Replace(Replace(Replace(Replace(c.Value, "elevé", "Elevé"), "Hty27", "HTY27"), "hty27", "HTY27"), "Hwa96", "HWA96"), "hwa96", "HWA96"), "cage", "Cage")
 
Upvote 0
Hello Jolievanes,
Thank you for your proposal, it gives the good result, however, I tested it on my database which is larger, the execution time is longer.
Thank you anyway.
Greetings.
 
Upvote 0
In all fairness to @jolivanes, I ran your data out over 100,000 lines and put a timer on both codes. Jolivanes code did run about 1 second quicker (on my machine, which is a pretty quick). I am posting both codes below with the timing lines of code included. If you run your data out to that many lines I think you will see the same result. Obvioulsly, 1 second is insignificant in the scheme of things but nonetheless... Total times were just under 3 seconds for your code and just under 2 seconds for Jolivanes.

VBA Code: 
Sub remplacer_Chaines()

    Dim StartTime As Double
    Dim SecondsElapsed As Double

   'Remember time when macro starts
    StartTime = Timer
    Application.ScreenUpdating = False
    
    Dim ws As Worksheet
    Dim arrReplace As Variant
    Dim strReplacement As String
    Dim i As Long

    Set ws = ThisWorkbook.Sheets("Parents")

    arrReplace = Array("elevé", "Hty27", "hty27", "Hwa96", "hwa96", "cage")
    For i = LBound(arrReplace) To UBound(arrReplace)

        Select Case arrReplace(i)
            Case "elevé"
                strReplacement = "Elevé"
            Case "Hty27", "hty27"
                strReplacement = "HTY27"
            Case "Hwa96", "hwa96"
                strReplacement = "HWA96"
            Case "cage"
                strReplacement = "Cage"

        End Select

        ws.Columns("K").Replace What:=arrReplace(i), Replacement:=strReplacement, LookAt:=xlPart, SearchOrder _
            :=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False

    Next i
    Application.ScreenUpdating = True
    'Determine how many seconds code took to run
    SecondsElapsed = Round(Timer - StartTime, 4)

    'Notify user in seconds
    MsgBox "This code ran successfully in " & SecondsElapsed & " seconds", vbInformation
    

End Sub

Sub Maybe_So()

    Application.ScreenUpdating = False
    Dim StartTime As Double
    Dim SecondsElapsed As Double

   'Remember time when macro starts
    StartTime = Timer

    Dim c As Range
    For Each c In Range("K2:K" & Cells(Rows.Count, 11).End(xlUp).Row)
        c.Value = Replace(Replace(Replace(Replace(Replace(Replace(c.Value, "elevé", "Elevé"), "Hty27", "HTY27"), "hty27", "HTY27"), "Hwa96", "HWA96"), "hwa96", "HWA96"), "cage", "Cage")
    Next c
    
    Application.ScreenUpdating = True
     'Determine how many seconds code took to run
    SecondsElapsed = Round(Timer - StartTime, 4)

    'Notify user in seconds
    MsgBox "This code ran successfully in " & SecondsElapsed & " seconds", vbInformation


End Sub
 
Upvote 0
See if this speeds it up for you.
VBA Code: 
Sub remplacer_Chaines()
    Dim ws As Worksheet
    Dim arrData As Variant
    Dim dictReplace As Object
    Dim i As Long
    Dim lastRow As Long
    Dim key As Variant

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    Set ws = ThisWorkbook.Sheets("Parents")
    lastRow = ws.Cells(ws.Rows.Count, "K").End(xlUp).Row

    If lastRow < 2 Then
        Application.ScreenUpdating = True
        Application.Calculation = xlCalculationAutomatic
        Exit Sub
    End If

    Set dictReplace = CreateObject("Scripting.Dictionary")
    dictReplace.Add "elevé", "Elevé"
    dictReplace.Add "Hty27", "HTY27"
    dictReplace.Add "hty27", "HTY27"
    dictReplace.Add "Hwa96", "HWA96"
    dictReplace.Add "hwa96", "HWA96"
    dictReplace.Add "cage", "Cage"

    arrData = ws.Range("K2:K" & lastRow).Value

    For i = LBound(arrData, 1) To UBound(arrData, 1)
        If Not IsEmpty(arrData(i, 1)) Then
            For Each key In dictReplace.Keys
                If InStr(1, arrData(i, 1), key, vbTextCompare) > 0 Then
                    arrData(i, 1) = Replace(arrData(i, 1), key, dictReplace(key))
                End If
            Next key
        End If
    Next i

    ws.Range("K2:K" & lastRow).Value = arrData

    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
End Sub
 
Last edited:
Upvote 0
I am still on an old machine so maybe someone has time to compare this also.
Code: 
Sub Or_So_Maybe()
Dim dataArr, i As Long, sh2 As Worksheet
Set ws = Worksheets("Parents")
dataArr = ws.Range("K1:K" & ws.Cells(ws.Rows.Count, 11).End(xlUp).Row).Value
    For i = LBound(dataArr) + 1 To UBound(dataArr)
        dataArr(i, 1) = Replace(Replace(Replace(Replace(Replace(Replace(dataArr(i, 1), "elevé", "Elevé"), "Hty27", "HTY27"), "hty27", "HTY27"), "Hwa96", "HWA96"), "hwa96", "HWA96"), "cage", "Cage")
    Next i
ws.Cells(1, 11).Resize(UBound(dataArr)).Value = dataArr
End Sub
I assume that the suggestion by cubist with dictionary will be the fastest.
It will be interesting to see the differences on a newer and presumably faster machine.
 
Upvote 0
Solution
You must log in or register to reply here.

Similar threads

H
  • Solved
Delete the last character of cells in column "K" if it is equal to "X" or "x"
Replies
8
Views
126
Fuji
F
H
  • Solved
Retrieve the intersection of multiple cells with respect to columns and rows
2
Replies
10
Views
107
mumps
mumps
H
  • Solved
Copy rows if cells in column "K" end with either "X" or "x".
Replies
3
Views
230
rollis13
rollis13
H
  • Solved
Capitalize the last character in column “K” conditionally.
Replies
3
Views
224
Fluff
Fluff
H
  • Solved
Modify content of cells in column "F" according to the content of cells in column "A"
Replies
5
Views
514
igold
igold

Forum statistics

Threads
1,223,877
Messages
6,175,137
Members
452,614
Latest member
MRSWIN2709

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top