Stitching values from one sheet to another

[MurdochQuill]

Hi all,

I'm using the following subroutine to stitch values from sheet "Stitch" col E to sheet "Sheet 1" col O

If it is a match, we then copy data from col F & G into col L & K onto Sheet 1.

This works if I have ONE match for each value in col E on "Stitch". But after using it for a while I have found I have multiple matches on "Sheet 1" col O. How would I rework the following so if it finds more than one match it can copy the data to ALL matches rather than just the first encountered match?

Sub StitchRunsComms()
Application.ScreenUpdating = False
Dim lastRw1, lastRw2, nxtRw, m
Dim wb As Workbook
Set ws = ThisWorkbook.Worksheets("Sheet 1")
Set tb = ThisWorkbook
   

' *** Logic for stitching back together ***
        With tb.Worksheets("Sheet 1")
       
                lastRw1 = ws.Range("O" & Rows.Count).End(xlUp).Row
                lastRw2 = Sheets("Stitch").Range("E" & Rows.Count).End(xlUp).Row
           
             For nxtRw = 1 To lastRw2
                 With ws.Range("O2:O" & lastRw1)
                      Set m = .Find(tb.Sheets("Stitch").Range("E" & nxtRw), LookIn:=xlValues, lookat:=xlWhole)
                            If Not m Is Nothing Then
                                 tb.Sheets("Stitch").Range("F" & nxtRw).Copy
                                 ws.Range("L" & m.Row).PasteSpecial xlValues
                                 tb.Sheets("Stitch").Range("G" & nxtRw).Copy
                                 ws.Range("K" & m.Row).PasteSpecial xlValues
                            End If
                           
                 End With
                
             Next
            
         End With
     tb.Worksheets("Stitch").Range("E1:G1001").Clear
            
End Sub

 

[Fluff]

How about

Sub MurdochQuill()
   Dim Ws1 As Worksheet, Ws2 As Worksheet
   Dim Cl As Range
   Dim Dic As Object
   
   Set Ws1 = ThisWorkbook.Sheets("Sheet 1")
   Set Ws2 = ThisWorkbook.Sheets("Stitch")
   Set Dic = CreateObject("scripting.dictionary")
   
   For Each Cl In Ws2.Range("E2", Ws2.Range("E" & Rows.Count).End(xlUp))
      Dic(Cl.Value) = Array(Cl.Offset(, 2).Value, Cl.Offset(, 1).Value)
   Next Cl
   For Each Cl In Ws1.Range("O2", Ws1.Range("O" & Rows.Count).End(xlUp))
      If Dic.exists(Cl.Value) Then Cl.Offset(, -4).Resize(, 2).Value = Dic(Cl.Value)
   Next Cl
End Sub

 

[MurdochQuill]

How about

Sub MurdochQuill()
   Dim Ws1 As Worksheet, Ws2 As Worksheet
   Dim Cl As Range
   Dim Dic As Object
  
   Set Ws1 = ThisWorkbook.Sheets("Sheet 1")
   Set Ws2 = ThisWorkbook.Sheets("Stitch")
   Set Dic = CreateObject("scripting.dictionary")
  
   For Each Cl In Ws2.Range("E2", Ws2.Range("E" & Rows.Count).End(xlUp))
      Dic(Cl.Value) = Array(Cl.Offset(, 2).Value, Cl.Offset(, 1).Value)
   Next Cl
   For Each Cl In Ws1.Range("O2", Ws1.Range("O" & Rows.Count).End(xlUp))
      If Dic.exists(Cl.Value) Then Cl.Offset(, -4).Resize(, 2).Value = Dic(Cl.Value)
   Next Cl
End Sub

Much more concise. I like this method a lot more.

 

[Fluff]

You're welcome & thanks for the feedback.