Delete and replace character without using helper cells

[abdo meghari]

Hi
I have many items are existed in the last item should be delete and replace for the others for instance any word contains JA or JAPAN then should be JAP
and if there items contain THA or TH or THAILAND then should convert to THI and if I have IND or INDONESIA then should convert to INDO . so I have about 1500 rows for the items

TIRES.xlsm
	A	B	C	D
1	ITEM	BRAND	QTY	BALANCE
2	1	BS 1200R20 18PR G580 TCF JA	1,147.00	791.00
3	2	BS 13R22.5 R187 JAP	60.00	-
4	3	BS 315/80R22.5 R184 THA	98.00	200.00
5	4	BS 315/80R22.5 G580 JAPAN	20.00	-
6	5	BS 1400R20 VSJ TCF THI	141.00	-
7	6	BS 1200R24 G580 JAP	194.00	100.00
8	7	BS 385/65R22.5 R164 INDO	70.00	-
9	8	BS 385/65R22.5 R164 THI	200.00	100.00
10	9	BS 1200R24 22PR G582 IND	100.00	100.00
11	10	BS 265/70R16 D840 INDONESIA	40.00	50.00
12	11	BS 205R16C D840 THAILAND	40.00	50.00
13	12	BS 195/65R15 EP150 TH	50.00	-
14	13	BS 205/70R15C R623 THI	200.00	360.00
15	14	BS 215/70R15C R623 THI	100.00	-
16	15	BS 175/70R13 EP150 THI	20.00	-
17	16	BS 235/55R17 T005 THI	40.00	-
18	17	BS 225/70R16 H005 JAP	150.00	-
19	18	BS 255/70R16 H005 JAP	95.00	-
DATA

RESULT

TIRES.xlsm
	A	B	C	D
1	ITEM	BRAND	QTY	BALANCE
2	1	BS 1200R20 18PR G580 TCF JAP	1,147.00	791.00
3	2	BS 13R22.5 R187 JAP	60.00	-
4	3	BS 315/80R22.5 R184 THI	98.00	200.00
5	4	BS 315/80R22.5 G580 JAP	20.00	-
6	5	BS 1400R20 VSJ TCF THI	141.00	-
7	6	BS 1200R24 G580 JAP	194.00	100.00
8	7	BS 385/65R22.5 R164 INDO	70.00	-
9	8	BS 385/65R22.5 R164 THI	200.00	100.00
10	9	BS 1200R24 22PR G582 INDO	100.00	100.00
11	10	BS 265/70R16 D840 INDO	40.00	50.00
12	11	BS 205R16C D840 THI	40.00	50.00
13	12	BS 195/65R15 EP150 THI	50.00	-
14	13	BS 205/70R15C R623 THI	200.00	360.00
15	14	BS 215/70R15C R623 THI	100.00	-
16	15	BS 175/70R13 EP150 THI	20.00	-
17	16	BS 235/55R17 T005 THI	40.00	-
18	17	BS 225/70R16 H005 JAP	150.00	-
19	18	BS 255/70R16 H005 JAP	95.00	-
DATA

 

[Shesil]

Are you using excel 365?

 

[igold]

How about this

Sub ChangeName()

    Dim arr, i As Long, p As Long, str As String
    
    arr = Range("B2:B" & Cells(Rows.Count, 2).End(xlUp).Row)
    For i = 1 To UBound(arr)
        p = InStrRev(arr(i, 1), " ")
        str = Mid(arr(i, 1), p + 1)
            Select Case str
                Case Is = "JA", "JAPAN"
                    arr(i, 1) = Replace(arr(i, 1), str, "JAP")
                Case Is = "THA", "TH", "THAILAND"
                    arr(i, 1) = Replace(arr(i, 1), str, "THI")
                Case Is = "IND", "INDONESIA"
                    arr(i, 1) = Replace(arr(i, 1), str, "INDO")
            End Select
    Next
    Range("B2").Resize(UBound(arr)) = arr
    
End Sub

 

[JEC]

Or simple like:

Sub jec()
 With Range("B2", Range("B" & Rows.Count).End(xlUp))
   .Replace "JA*", "JAP", 2
   .Replace "TH*", "THI", 2
   .Replace "IND*", "INDO", 2
 End With
End Sub

 

[abdo meghari]

Are you using excel 365?

I think you should see my profile .

 

[igold]

@JEC gives you a good solution and you are worried about a new member missing your profile details. I don't get it...

 

[abdo meghari]

@JEC gives you a good solution and you are worried about a new member missing your profile details. I don't get it...

take it easy . I'm still test it . and just answer one by one .
thanks for your code

 

[abdo meghari]

@JEC thanks for short and efficient code

 

[igold]

take it easy . I'm still test it . and just answer one by one .
thanks for your code

Perhaps, it just seems like wasted keystrokes. Thanks for the feedback, we were all happy to help.