Find/Compare and Copy Certain Cells

[ScabbyDog]

I have the below code which deletes the row in SheetM if a match is found. But I want to alter it so that if it finds a match in sheetLW then I want it to copy what is in col F,G,H in sheetLW and paste into sheetM col H,I and J.

Sub Alter()

    Dim rsht1 As Long, rsht2 As Long
    
    rsht1 = Sheets("SheetM").Range("A" & Rows.Count).End(xlUp).Row
    rsht2 = Sheets("SheetLW").Range("A" & Rows.Count).End(xlUp).Row
    
    For i = 1 To rsht1
        For j = 1 To rsht2
       
            If Sheets("SheetM").Range("B" & i) = Sheets("SheetLW").Range("C" & j) Then
              
                Sheets("SheetM").Rows(i).Select
                Selection.Delete Shift:=xlUp
            End If
        Next
    Next
         
End Sub

[AB33]

Untested code

Sub Alter()

    Dim c3 As Range, c4 As Range, LR2 As Long, LR1&, ms As Worksheet
    
    Application.ScreenUpdating = 0
    Application.EnableEvents = 0
    Set ms = Sheets("SheetM")
    
With Sheets("SheetM")

    LR2 = Worksheets("SheetM").Cells(Rows.Count, 1).End(xlUp).Row
    LR1 = Worksheets("SheetLW").Cells(Rows.Count, 1).End(xlUp).Row
    
    For Each c4 In .Range("B2:B" & LR2)
    
    If Len(c4) Then
    
            Set c3 = Sheets("SheetLW").Range("C2:C" & LR1).Find(c4, , xlValues, xlWhole)
    
                If Not c3 Is Nothing Then

                c3.Offset(, 4).Resize(, 3).Copy ms.Cells(Rows.Count, "H").End(xlUp).Offset(1).Resize(, 3)
       
                End If
    End If
    Next
End With
Application.ScreenUpdating = 1
Application.EnableEvents = 1

Set ms = Nothing
End Sub

[ScabbyDog]

What If I want what is in col D in LW to be put into col C on sheetM as well as the above?

[AB33]

Amended

Sub Alter()

    Dim c3 As Range, c4 As Range, LR2 As Long, LR1&, ms As Worksheet
    
    Application.ScreenUpdating = 0
    Application.EnableEvents = 0
    Set ms = Sheets("SheetM")
    
With Sheets("SheetM")

    LR2 = Worksheets("SheetM").Cells(Rows.Count, 1).End(xlUp).Row
    LR1 = Worksheets("SheetLW").Cells(Rows.Count, 1).End(xlUp).Row
    
    For Each c4 In .Range("B2:B" & LR2)
    
    If Len(c4) Then
    
            Set c3 = Sheets("SheetLW").Range("C2:C" & LR1).Find(c4, , xlValues, xlWhole)
    
                If Not c3 Is Nothing Then

               ms.Cells(c4.Row, 8).Resize(, 3) = c3.Offset(, 3).Resize(, 3)
               ms.Cells(c4.Row, 3).Resize(, 1) = c3.Offset(, 1).Resize(, 1)
       
                End If
    End If
    Next
End With
Application.ScreenUpdating = 1
Application.EnableEvents = 1

Set ms = Nothing
End Sub

[ScabbyDog]

Your code pastes the values to the bottom of SHeetM and not in the same row as the match was found.

[AB33]

Sorry,
My offset was wrong, Should have been

c3.Offset(, 3).Resize(, 3).Copy ms.Cells(Rows.Count, "H").End(xlUp).Offset(1).Resize(, 3)

Second request

 c3.Offset(, 1).Resize(, 1).Copy ms.Cells(Rows.Count, "C").End(xlUp).Offset(1).Resize(, 1)

[ScabbyDog]

I'll test that now. Many thanks!

[ScabbyDog]

Works better. Almost there. Except with ( ms.Cells(c4.Row, 8).Resize(, 3) = c3.Offset(, 3).Resize(, 3) ) instead of copying and pasting whats in SheetLW into SheetM all it does is clear the contents of the cells in SheetM.

[AB33]

Hmmm! Column H and C of sheet LW should be blank

Try this one then

 c3.Offset(, 3).Resize(, 3).Copy ms.Cells(c4.Row, 8).Resize(, 3)
 c3.Offset(, 1).Resize(, 1).Copy ms.Cells(c4.Row, 3).Resize(, 1)

[ScabbyDog]

Not quite what I need. Very close. Perhaps I know why, can you please adjust it. I need M, N, O, P, Q and R in SheetLW to be put into SheetM G, H, I, J, K, L.

[AB33]

 c3.Offset(, 10).Resize(, 6).Copy ms.Cells(c4.Row, 7).Resize(, 6)
 'c3.Offset(, 1).Resize(, 1).Copy ms.Cells(c4.Row, 3).Resize(, 1)