SOLVED

Find the String if Match then write to adjacent Columns

Brass Contributor

I have created this code which finds the string in Column and if macthes then write the values in adjacent columns.

currently my code is using Sheet2 Row2 values to update the data in Sheet1. I want to include the all rows that are available in Sheet2

I want to make it dyanmic. I will appreciated your help.

 

attached a sheet as well for better understanding.

4 Replies
best response confirmed by ShazSh (Brass Contributor)
Solution

 

Sub Updatevalues()
    Dim lastrow As Long, rng As Range
    Dim lastrow2 As Long, rng2 As Range, cel As Range
    Application.ScreenUpdating = False
    With Sheet2
        lastrow2 = .Cells(.Rows.Count, "B").End(xlUp).Row
        Set rng2 = .Range("B2:B" & lastrow2)
    End With
    For Each cel In rng2
        With Sheet1
            .AutoFilterMode = False
            lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
            Set rng = .Range("B1:B" & lastrow)
            rng.AutoFilter Field:=1, Criteria1:=cel.Value & "*"
            On Error Resume Next
            rng.Offset(1, 2).SpecialCells(12).Value = cel.Offset(0, 1).Value
            rng.Offset(1, 3).SpecialCells(12).Value = cel.Offset(0, 2).Value
            rng.Offset(1, 4).SpecialCells(12).Value = cel.Offset(0, 3).Value & ""
            On Error GoTo 0
        End With
    Next cel
    With Sheet1
        .Cells(lastrow + 1, 4).Resize(1, 3).ClearContents
        .AutoFilterMode = False
    End With
    Application.ScreenUpdating = True
End Sub

@ShazSh 

Sir i have updated the new workbook with other values in Sheet2 but its not updating data for last value smoke.

@ShazSh 

That is because the entries on Sheet1 don't begin with "THE SMOKE PIT":

 

SQ *THE SMOKE PIT PTY Thomastown

 

Change the line

            rng.AutoFilter Field:=1, Criteria1:=cel.Value & "*"

to

            rng.AutoFilter Field:=1, Criteria1:="*" & cel.Value & "*"
Thank you very much Sir. This help means alot.
1 best response

Accepted Solutions
best response confirmed by ShazSh (Brass Contributor)
Solution

 

Sub Updatevalues()
    Dim lastrow As Long, rng As Range
    Dim lastrow2 As Long, rng2 As Range, cel As Range
    Application.ScreenUpdating = False
    With Sheet2
        lastrow2 = .Cells(.Rows.Count, "B").End(xlUp).Row
        Set rng2 = .Range("B2:B" & lastrow2)
    End With
    For Each cel In rng2
        With Sheet1
            .AutoFilterMode = False
            lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
            Set rng = .Range("B1:B" & lastrow)
            rng.AutoFilter Field:=1, Criteria1:=cel.Value & "*"
            On Error Resume Next
            rng.Offset(1, 2).SpecialCells(12).Value = cel.Offset(0, 1).Value
            rng.Offset(1, 3).SpecialCells(12).Value = cel.Offset(0, 2).Value
            rng.Offset(1, 4).SpecialCells(12).Value = cel.Offset(0, 3).Value & ""
            On Error GoTo 0
        End With
    Next cel
    With Sheet1
        .Cells(lastrow + 1, 4).Resize(1, 3).ClearContents
        .AutoFilterMode = False
    End With
    Application.ScreenUpdating = True
End Sub

@ShazSh 

View solution in original post