match strings and copy it to adjacent cell

[lady_alina]

Hi,

Here I'm again with another problem... please help me experts..

I have data in column B sheet 1 which is something like this - 123alina09032015 &
I have data in column A sheet 2 which is like this - alina.

The data is huge and keeps adding every month. So what I want is a VBA code to match the words from column A sheet 2 and column b sheet1 and paste it to the adjacent cell in column c of sheet 1

I have a code but that only finds the exact match and pastes it to column c in sheet 1. Here is the code:

Sub CopyBasedonSheet1()

Dim i As Long
Dim j As Long
Sheet1LastRow = Worksheets("sheet1").Range("B" & Rows.Count).End(xlUp).Row
Sheet2LastRow = Worksheets("sheet2").Range("A" & Rows.Count).End(xlUp).Row


    For j = 1 To Sheet1LastRow
        For i = 1 To Sheet2LastRow
            If Worksheets("sheet1").Cells(j, 1).Value = Worksheets("sheet2").Cells(i, 4).Value Then
                Worksheets("sheet1").Cells(j, 3).Value = Worksheets("sheet2").Cells(i, 1).Value
            Else
        End If
    Next i
Next j
End Sub

Looking forward to your answer.

 

[JLGWhiz]

It is always better to work from a mockup illustration or a screen shot, but maybe this method would work.

Sub CopyBasedonSheet1()
Dim i As Long
Dim j As Long
Sheet1LastRow = Worksheets("sheet1").Range("B" & Rows.Count).End(xlUp).Row
Sheet2LastRow = Worksheets("sheet2").Range("A" & Rows.Count).End(xlUp).Row
    For j = 1 To Sheet1LastRow
        For i = 1 To Sheet2LastRow
            If InStr(Worksheets("sheet1").Cells(j, 1).Value), Worksheets("sheet2").Cells(i, 4).Value) > 0 Then
                Worksheets("sheet1").Cells(j, 3).Value = Worksheets("sheet2").Cells(i, 1).Value
            Else
        End If
    Next i
Next j
End Sub

 

[lady_alina]

Thanks JLGWhiz for your answer however the line below appears red when i paste it and shows error when I run the macro.

[COLOR=#333333]If InStr(Worksheets("sheet1").Cells(j, 1).Value), Worksheets("sheet2").Cells(i, 4).Value) > 0 Then[/COLOR]

 

[lady_alina]

When I run this code it takes too long to return the value and more over the code gives only one value which is exactly matched and copys it to entire rows of columns c .. here is what I want with examples


Sheet1.................................................................THIS IS THE OUTPUT COLUMN C AND THIS ARE THE VALUES THAT IT SHOULD RETURN
[TABLE="class: grid, width: 500, align: left"]
<tbody>[TR]
[TD]column A[/TD]
[TD]column B[/TD]
[TD]column C[/TD]
[/TR]
[TR]
[TD]STR109[/TD]
[TD]RTE00ALINA000[/TD]
[TD]ALINA[/TD]
[/TR]
[TR]
[TD]STR986[/TD]
[TD]TRH00PETER000[/TD]
[TD]PETER[/TD]
[/TR]
[TR]
[TD]STR341[/TD]
[TD]GHE00JOHN000[/TD]
[TD]JOHN[/TD]
[/TR]
[TR]
[TD]STR001[/TD]
[TD]PWR00JAMES000[/TD]
[TD]JAMES[/TD]
[/TR]
</tbody>[/TABLE]










Find column A of sheet 2 in column B of sheet1 and paste the matching values in column c of sheet1
Sheet2
[TABLE="class: grid, width: 100, align: left"]
<tbody>[TR]
[TD]column A[/TD]
[/TR]
[TR]
[TD]PETER[/TD]
[/TR]
[TR]
[TD]ALINA[/TD]
[/TR]
[TR]
[TD]JAMES[/TD]
[/TR]
[TR]
[TD]JOHN[/TD]
[/TR]
</tbody>[/TABLE]

 

[JLGWhiz]

If InStr(Worksheets("sheet1").Cells(j, 1).Value, Worksheets("sheet2").Cells(i, 4).Value) > 0 Then

Had too many right Parenthesis in it. Haste makes waste they say. Try it without the extra parenthsis.

 

[JLGWhiz]

This might be faster.

Sub CopyBasedonSheet1()
Dim i As Long
Dim j As Long, fn As Range, sh As Worksheet, fAdr As String
Set sh = Sheets("Sheet1")
Sheet2LastRow = Worksheets("sheet2").Range("A" & Rows.Count).End(xlUp).Row
    For i = 1 To Sheet2LastRow
        Set fn = sh.Range("B:B").Find(Sheets("Sheet2").Cells(i, 1).Value, , xlValues, xlPart)
        If Not fn Is Nothing Then
            fAdr = fn.Address
                Do
                    fn.Offset(0, 1) = Sheets("Sheet2").Cells(i, 1).Value
                    Set fn = sh.Range("B:B").FindNext(fn)
                Loop While fAdr <> fn.Address
        End If
    Next
End Sub

 

[lady_alina]

Perfect... Thank you JLGWhiz.... it worked... if there is way to rate you or something let me know please I would love to do that..

 

[lady_alina]

You really are an expert...

 

[JLGWhiz]

You really are an expert...

there's a button somewhere on the page, but it isn't necessary. Thanks is good enough.
Regards, JLG

 

[lady_alina]

Hi JLGWHIZ, will you be able to help me with one more thing like if more than one matching word is found like in RTEALINAPETER00123 (sheet1 /column B) there are 2 words Alina and peter from sheet 2 column A so can we make changes to the code where it can copy both in column c of sheet1 seperated by comma like Alina,Peter.