Find a value in a sheet and replace it with another value if it matches

[XR8 Sprintless]

I have a workbook with several sheets

DATA Errata and Errata 2

Data contains a large list of value but of interest is column D

I want to find if a partial value listed in Column D matches a value in
column A of errata then copy the value from Column C in Errata to column
D in data


EG

Data sheet column D contains the entry 123456ABC

Errata sheet column A row 3 contains 123456
Errata sheet column C row 3 contains XYZABC12

If the partial match is found I want the value in column D whatever row
it is in to now equal XYZABC12


So on a bigger scale

DATA_D ERRATA_A ERRATA_C
123abc 123 XYZ132
234abc 234a XZY495
678bde 132q PSU091
132qwe 678b ddeeff

Should have column D become
XYZ132
XZY495
ddeeff
PSU091

I've tried this but it doesn't work

Sub ReplaceMatches()

Dim shtOld As Worksheet, shtNew As Worksheet
Dim oldRow As Integer
Dim newRow As Integer
Dim i As Integer, id, f As Range



Set shtOld = ThisWorkbook.Sheets("Errata")
Set shtNew = ThisWorkbook.Sheets("Data")


For oldRow = 2 To 1711

id = shtOld.Cells(oldRow, 1)

Set f = shtNew.Range("D21711").Find(id, , xlValues, xlPart)
If Not f Is Nothing Then
shtNew.activeCell.value = shtOld.Cells(oldRow, 3)


End If

Next oldRow

I know I'm not getting the right cell somewhere. Can someone help?

 

[Claus Busch]

Hi,

Am Tue, 02 Sep 2014 19:53:55 +1000 schrieb XR8 Sprintless:

Data sheet column D contains the entry 123456ABC

Errata sheet column A row 3 contains 123456
Errata sheet column C row 3 contains XYZABC12

If the partial match is found I want the value in column D whatever row
it is in to now equal XYZABC12

So on a bigger scale

DATA_D ERRATA_A ERRATA_C
123abc 123 XYZ132
234abc 234a XZY495
678bde 132q PSU091
132qwe 678b ddeeff

Should have column D become
XYZ132
XZY495
ddeeff
PSU091

try:

Sub ReplaceMatches()

Dim shtOld As Worksheet, shtNew As Worksheet
Dim i As Integer, f As Range
Dim LRowD As Long, LRowE As Long
Dim FirstAddress As String

Set shtOld = ThisWorkbook.Sheets("Errata")
Set shtNew = ThisWorkbook.Sheets("Data")

With shtOld
LRowE = .Cells(Rows.Count, 1).End(xlUp).Row
LRowD = shtNew.Cells(Rows.Count, 4).End(xlUp).Row
For i = 2 To LRowE
Set f = shtNew.Range("D2" & LRowD).Find(.Cells(i, 1), _
LookIn:=xlValues, lookat:=xlPart)
If Not f Is Nothing Then
FirstAddress = f.Address
Do
shtNew.Cells(f.Row, 4) = .Cells(i, 3)
Set f = shtNew.Range("D2" & LRowD).FindNext(f)
Loop While Not f Is Nothing And f.Address <> FirstAddress
End If
Next i
End With
End Sub


Regards
Claus B.

 

[XR8 Sprintless]

On 2/09/2014 9:55 PM, Claus Busch wrote:
Hi

Thanks for your assistance.

try:

Sub ReplaceMatches()

Dim shtOld As Worksheet, shtNew As Worksheet
Dim i As Integer, f As Range
Dim LRowD As Long, LRowE As Long
Dim FirstAddress As String

Set shtOld = ThisWorkbook.Sheets("Errata")
Set shtNew = ThisWorkbook.Sheets("Data")

With shtOld
LRowE = .Cells(Rows.Count, 1).End(xlUp).Row
LRowD = shtNew.Cells(Rows.Count, 4).End(xlUp).Row
For i = 2 To LRowE
Set f = shtNew.Range("D2" & LRowD).Find(.Cells(i, 1), _
LookIn:=xlValues, lookat:=xlPart)
If Not f Is Nothing Then
FirstAddress = f.Address
Do
shtNew.Cells(f.Row, 4) = .Cells(i, 3)
Set f = shtNew.Range("D2" & LRowD).FindNext(f)
Loop While Not f Is Nothing And f.Address <> FirstAddress
End If
Next i
End With
End Sub

It errors at the Loop While Not f is nothing line after replacing the
first value.
Run time error 91 Object variable or with block variable not set?

 

[Claus Busch]

Hi,

Am Tue, 02 Sep 2014 22:53:51 +1000 schrieb XR8 Sprintless:

It errors at the Loop While Not f is nothing line after replacing the
first value.

try:

Sub ReplaceMatches()

Dim shtOld As Worksheet, shtNew As Worksheet
Dim i As Integer, f As Range
Dim LRowD As Long, LRowE As Long
Dim FirstAddress As String

Set shtOld = ThisWorkbook.Sheets("Errata")
Set shtNew = ThisWorkbook.Sheets("Data")

On Error Resume Next
With shtOld
LRowE = .Cells(Rows.Count, 1).End(xlUp).Row
LRowD = shtNew.Cells(Rows.Count, 4).End(xlUp).Row
For i = 2 To LRowE
Set f = shtNew.Range("D2" & LRowD).Find(.Cells(i, 1), _
LookIn:=xlValues, lookat:=xlPart)
If Not f Is Nothing Then
FirstAddress = f.Address
Do
shtNew.Cells(f.Row, 4) = .Cells(i, 3)
Set f = shtNew.Range("D2" & LRowD).FindNext(f)
Loop While Not f Is Nothing And f.Address <> FirstAddress
End If
Next i
End With
End Sub


Regards
Claus B.

 

[XR8 Sprintless]

Hi,

Am Tue, 02 Sep 2014 22:53:51 +1000 schrieb XR8 Sprintless:


On Error Resume Next

Thanks, that seems to have resolved the issue.

 

[GS]

Try...

Sub ReplaceMatches2()
Dim vDataSource, vDataTarget, n&

vDataSource = Sheets("Errata").Range("A2:C1711")
vDataTarget = Sheets("Data").Range("D21711")

vDataSource = rngSource: vDataTarget = rngTarget

For n = LBound(vDataSource) To UBound(vDataSource)
If InStr(vDataTarget(n, 1), vDataSource(n, 1)) > 0 Then _
vDataTarget(n, 1) = vDataSource(n, 3)
Next 'n
Sheets("Data").Range("D21711") = vDataTarget
End Sub

--
Garry

Free usenet access at http://www.eternal-september.org
Classic VB Users Regroup!
comp.lang.basic.visual.misc
microsoft.public.vb.general.discussion

 

[GS]

Oops! I forgot to check all instances...

Sub ReplaceMatches2()
Dim vDataSource, vDataTarget, n&, j&

vDataSource = Sheets("Errata").Range("A2:C1711")
vDataTarget = Sheets("Data").Range("D21711")

vDataSource = rngSource: vDataTarget = rngTarget

For n = LBound(vDataSource) To UBound(vDataSource)
For j = LBound(vDataTarget) To UBound(vDataTarget)
If InStr(vDataTarget(j, 1), vDataSource(n, 1)) > 0 Then _
vDataTarget(j, 1) = vDataSource(n, 3)
Next 'j
Next 'n
Sheets("Data").Range("D21711") = vDataTarget
End Sub

--
Garry

Free usenet access at http://www.eternal-september.org
Classic VB Users Regroup!
comp.lang.basic.visual.misc
microsoft.public.vb.general.discussion

 

[Claus Busch]

Hi Garry,

Am Wed, 03 Sep 2014 09:39:45 -0400 schrieb GS:

vDataSource = Sheets("Errata").Range("A2:C1711")
vDataTarget = Sheets("Data").Range("D21711")

the lines above fill perfectly your arrays

vDataSource = rngSource: vDataTarget = rngTarget

This line is not needed and erase the arrays


Regards
Claus B.

 

[GS]

Thanks, Claus! I originally used the vars but reduced the code to put
the data directly into the arrays. I deleted the 'Set' statements but
forgot to delete that line...

Sub ReplaceMatches2()
Dim vDataSource, vDataTarget, n&, j&

vDataSource = Sheets("Errata").Range("A2:C1711")
vDataTarget = Sheets("Data").Range("D21711")

For n = LBound(vDataSource) To UBound(vDataSource)
For j = LBound(vDataTarget) To UBound(vDataTarget)
If InStr(vDataTarget(j, 1), vDataSource(n, 1)) > 0 Then _
vDataTarget(j, 1) = vDataSource(n, 3)
Next 'j
Next 'n
Sheets("Data").Range("D21711") = vDataTarget
End Sub

--
Garry

Free usenet access at http://www.eternal-september.org
Classic VB Users Regroup!
comp.lang.basic.visual.misc
microsoft.public.vb.general.discussion