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

  • Thread starter Thread starter XR8 Sprintless
  • Start date Start date
X

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("D2:D1711").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?
 
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
Click to expand...

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:D" & 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:D" & LRowD).FindNext(f)
Loop While Not f Is Nothing And f.Address <> FirstAddress
End If
Next i
End With
End Sub


Regards
Claus B.
 
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:D" & 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:D" & LRowD).FindNext(f)
Loop While Not f Is Nothing And f.Address <> FirstAddress
End If
Next i
End With
End Sub
Click to expand...
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?
 
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.
Click to expand...

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:D" & 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:D" & LRowD).FindNext(f)
Loop While Not f Is Nothing And f.Address <> FirstAddress
End If
Next i
End With
End Sub


Regards
Claus B.
 
Try...

Sub ReplaceMatches2()
Dim vDataSource, vDataTarget, n&

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

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("D2:D1711") = 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
 
Oops! I forgot to check all instances...

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

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

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("D2:D1711") = 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
 
Hi Garry,

Am Wed, 03 Sep 2014 09:39:45 -0400 schrieb GS:
vDataSource = Sheets("Errata").Range("A2:C1711")
vDataTarget = Sheets("Data").Range("D2:D1711")
Click to expand...

the lines above fill perfectly your arrays
vDataSource = rngSource: vDataTarget = rngTarget
Click to expand...

This line is not needed and erase the arrays


Regards
Claus B.
 
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("D2:D1711")

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("D2:D1711") = 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
 
Back
Top