Vba, find and replace but first occurrence only

[yousufj567]

Hi everyone,

Long time reader, first time poster.

Sheet1 contains 196 rows that contain the word "ToReplace" as part of larger string.
Sheet2 contains 196 rows that contain only the word "ToReplace" in column A and a unique value in column B.

I need to replace Sheet1 "ToReplace" with the unique value in column B.



Sheet1 Sheet2
[TABLE="width: 500"]
<tbody>[TR]
[TD]ToReplace[/TD]
[TD]ToReplace[/TD]
[TD]12345[/TD]
[/TR]
[TR]
[TD]ToReplace[/TD]
[TD]ToReplace[/TD]
[TD]56784[/TD]
[/TR]
[TR]
[TD]ToReplace[/TD]
[TD]ToReplace[/TD]
[TD]76543[/TD]
[/TR]
</tbody>[/TABLE]


This is the code i found online:

Sub myReplace()


Dim myDataSheet As Worksheet
Dim myReplaceSheet As Worksheet
Dim myLastRow As Long
Dim myRow As Long
Dim myFind As String
Dim myReplace As String

' Specify name of Data sheet
Set myDataSheet = Sheets("Sheet1")

' Specify name of Sheet with list of replacements
Set myReplaceSheet = Sheets("Sheet2")

' Assuming list of replacement start in column A on row 2, find last entry in list
myLastRow = myReplaceSheet.Cells(Rows.Count, "A").End(xlUp).Row

Application.ScreenUpdating = False

' Loop through all list of replacments
For myRow = 2 To myLastRow
' Get find and replace values (from columns A and B)
myFind = myReplaceSheet.Cells(myRow, "A")
myReplace = myReplaceSheet.Cells(myRow, "B")
' Start at top of data sheet and do replacements
myDataSheet.Activate
Range("A1").Select
' Ignore errors that result from finding no matches
On Error Resume Next
' Do all replacements on column A of data sheet
Columns("A:A").Replace What:=myFind, Replacement:=myReplace, LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
' Reset error checking
On Error GoTo 0
Next myRow

Application.ScreenUpdating = True

MsgBox "Replacements complete!"

End Sub

 

[Akuini]

Re: Help!! Vba, find and replace but first occurrence only

Hi everyone,

Long time reader, first time poster.

Sheet1 contains 196 rows that contain the word "ToReplace" as part of larger string.
Sheet2 contains 196 rows that contain only the word "ToReplace" in column A and a unique value in column B.

I need to replace Sheet1 "ToReplace" with the unique value in column B.

Try this:
Sheet1 should be the active sheet

Sub a1013082a()
Dim va, vb
Dim i As Long, j As Long
Dim va, vb

With Sheets("sheet2")
vb = .Range("A2", .Cells(Rows.count, "B").End(xlUp))
End With

va = Range("A2", Cells(Rows.count, "A").End(xlUp))
For i = 1 To UBound(va, 1)
    For j = 1 To UBound(vb, 1)
        If InStr(va(i, 1), vb(j, 1)) Then
         va(i, 1) = Replace(va(i, 1), vb(j, 1), vb(j, 2))
        End If
    Next
Next
Range("A2").Resize(UBound(va, 1), 1) = va

End Sub

 

[yousufj567]

Re: Help!! Vba, find and replace but first occurrence only

Try this:
Sheet1 should be the active sheet

Sub a1013082a()
Dim va, vb
Dim i As Long, j As Long
Dim va, vb

With Sheets("sheet2")
vb = .Range("A2", .Cells(Rows.count, "B").End(xlUp))
End With

va = Range("A2", Cells(Rows.count, "A").End(xlUp))
For i = 1 To UBound(va, 1)
    For j = 1 To UBound(vb, 1)
        If InStr(va(i, 1), vb(j, 1)) Then
         va(i, 1) = Replace(va(i, 1), vb(j, 1), vb(j, 2))
        End If
    Next
Next
Range("A2").Resize(UBound(va, 1), 1) = va

End Sub

Hey, thanks for your feedback. However, it still changed it all instead of the first occurrence. Any other ideas? I really need this to work.

 

[Akuini]

Re: Help!! Vba, find and replace but first occurrence only

Hey, thanks for your feedback. However, it still changed it all instead of the first occurrence. Any other ideas? I really need this to work.

Oh, sorry, forget that you want to replace only the first one. Try this one:

Sub a1013082b()
Dim i As Long, j As Long
Dim va, vb

With Sheets("sheet2")
vb = .Range("A2", .Cells(Rows.count, "B").End(xlUp))
End With

va = Range("A2", Cells(Rows.count, "A").End(xlUp))
For j = 1 To UBound(vb, 1)
    For i = 1 To UBound(va, 1)
        If InStr(va(i, 1), vb(j, 1)) Then
         va(i, 1) = Replace(va(i, 1), vb(j, 1), vb(j, 2))
         Exit For
        End If
    Next
Next
Range("A2").Resize(UBound(va, 1), 1) = va

End Sub

 

[yousufj567]

Re: Help!! Vba, find and replace but first occurrence only

Oh, sorry, forget that you want to replace only the first one. Try this one:

Sub a1013082b()
Dim i As Long, j As Long
Dim va, vb

With Sheets("sheet2")
vb = .Range("A2", .Cells(Rows.count, "B").End(xlUp))
End With

va = Range("A2", Cells(Rows.count, "A").End(xlUp))
For j = 1 To UBound(vb, 1)
    For i = 1 To UBound(va, 1)
        If InStr(va(i, 1), vb(j, 1)) Then
         va(i, 1) = Replace(va(i, 1), vb(j, 1), vb(j, 2))
         Exit For
        End If
    Next
Next
Range("A2").Resize(UBound(va, 1), 1) = va

End Sub

Geniuss!! it works!

Thank you so much. I really need this help.

 

[Akuini]

Re: Help!! Vba, find and replace but first occurrence only

Geniuss!! it works!

Thank you so much. I really need this help.

You're welcome & thanks for replying

 

[Rafaelete]

Hey, I have the same problem but a bit more complex. I want to only make the change once in the following code:

Dim Wbk As Workbook: Set Wbk = ThisWorkbook
Dim Wrd As New Word.Application
Dim Dict As Object
Dim RefList As Range, RefElem As Range
Dim Key
Dim wrdRng As Range
Dim WDoc As Document


Wrd.Visible = True

Set WDoc = Wrd.Documents.Open(filename:=sFileName, OpenAndRepair:=True) 'Modify as necessary.

Debug.Print sFileName

' Activar control de cambios en cada documento
With WDoc:
.TrackRevisions = False
WDoc.ActiveWindow.View.MarkupMode = wdBalloonRevisions
End With

'Assigns the columns that is going to have the original texts that need to be changed
Set Dict = CreateObject("Scripting.Dictionary")
Set RefList = Wbk.Sheets("Reemplazos").Range("B2:B50") 'Modify as necessary.


'Selects the column that´s one column to the right of the reference column
With Dict
For Each RefElem In RefList
If Not .Exists(RefElem) And Not IsEmpty(RefElem) Then
.Add RefElem.Value, RefElem.Offset(0, 1).Value
Debug.Print RefElem
End If
Next RefElem
End With

'Assigns the conditions and loops through each text to replace it
For Each Key In Dict
With WDoc.Content.FIND
Debug.Print Key
.Execute MatchAllWordForms:=False
.Execute Forward:=True
.Execute Wrap:=wdFindAsk
.Execute Format:=False
.Execute MatchCase:=False
.Execute MatchWildcards:=False
.Execute MatchSoundsLike:=False
.Execute wdReplaceAll
.Execute FindText:=Key, ReplaceWith:=Dict(Key), Replace:=2
End With
Next Key

The problem I have is with trackchanges. I have to active it due to the requirements of the automatization, but I´m finding myself with two words been changed twice. When I do it without trackchanges it works just fine.

This is an example of the problem I have. These are words that I´m replacing:

Buscar	Reemplazar
Trading - Energy Management Iberia - Strategic Short Term Manag.Ibe	EM Iberia - Strategic Short Term Mng. Ibe
Trading - Energy Management Iberia - Back Office Iberia (Operations)	REVISAR
Trading - Energy Management Iberia - Back Office Iberia (Int. & Coord. Inf.)	REVISAR
REVISAR	REVISAR
Responsable actividad	REVISAR
Global Digital Solutions - Trading Digital Hub - Adoption	REVISAR
Global Digital Solutions - Trading Digital Hub - Adoption	DISTINTOS NIVELES
EM Iberia - Strategic Short Term Mng. Ibe	REVISAR
EM Iberia - EM Iberia - Credit & BO Ibe (Int. & Coord. Inf.)	REVISAR
EM Iberia - Credit & BO Ibe - Operations	REVISAR
EM Iberia - Credit & BO Ibe - Operations	REVISAR
AFC - Administration Iberia - Accounting Iberia (Energetic Business)	ADM Iberia - Accounting Ibe - Negocios Energéticos
AFC - Administration Iberia - Accounting Iberia	BUSTED
ADM Iberia-Contabilidad-Negocios Energéticos-Balance de Energía	REVISAR
AA2	REVISAR
AA1	REVISAR
Activity Owner	REVISAR

The problem I´m having is with these two words:
It changes the first one just fine, but then it changes the second one in the same words as if it wasn´t changed.

AFC - Administration Iberia - Accounting Iberia (Energetic Business)	ADM Iberia - Accounting Ibe - Negocios Energéticos
AFC - Administration Iberia - Accounting Iberia	BUSTED

This is the result I´m getting:

Without trackchanges, it does the change without any problems:

I need to get this result with trackchanges as true. But I´m unable to do it.

Any help will be greatly appreciated. Thanks a lot in advance.

 

[Akuini]

@Rafaelete
Your problem is different from the OP's problem in that it involves Word macro. I suggest you post a new thread. The new thread will attract more members to help.