Compare two cells and copy them / 2 workbooks

Question

I hope someone can help me.. I am a beginner and sit here since 5 hours to do this work :(

I need to compare two cells. When the Cell 1 have the same value than Cell 2 i have to copy the value into the next 3 cells next to cell 2. When they aren't the same value, then the loop should go one cell down. And this down to the last filled cell.

Workbook 1 have the range G1:G100 this should be compared with the Workbook 2 and range B1:100

If the the content is the same in both, then i have to copy the 3 next cells next to the WB2 range where the cells are similar C1:E100

And thats the code i have

Public Sub zusammenführen()
Dim cell As Range
Dim wb1 As Workbook
Set wb1 = ThisWorkbook
Dim wb2 As Workbook
Set wb2 = Application.Workbooks.Open("T:\folder\LWTP.xlsx")

For Each cell In wb1.Sheets(1).Range("G1:G100")
    If ActiveCell.Value = wb2.Sheets("LWTP").Range("B1:B100").Value Then
    MsgBox "Test"

    End If
Next cell
End Sub

I hope you understand my english Thanks for help!

Answer 1

Try this:

Public Sub zusammenführen()
    Dim cell As Range
    Dim wb1 As Workbook
    Dim wb2 As Workbook, ws2 as worksheet

    Set wb1 = ThisWorkbook   
    Set wb2 = Application.Workbooks.Open("T:\folder\LWTP.xlsx")
    Set ws2 = wb2.Sheets("LWTP") 

    For Each cell In wb1.Sheets(1).Range("G1:G100")
        If cell.Value = ws2.Cells(cell.Row, "B").Value Then

            cell.offset(0, 1).Resize(1, 3).Value = _
                ws2.Cells(cell.Row, "C").Resize(1, 3).Value

        End If
    Next cell

End Sub