Matching data on two separate sheets and copying from one to another

[eonizuka]

What I would like to have done is as follows;

If the name in Column F of "Sheet1" is found in "DataPEs" in Column B, then copy the block of 6 cells of data below it in column Q to column D of "Sheet1" in their relative rows. Additionally, if column Q has data then copy it, if not then copy the data only in column M. Finally, the number of matching names will vary in Sheet1 but will stay mostly the same in the DataPEs sheet. I've highlighted one block of data in green as an example.

If anybody would be willing to help with this I would greatly appreciate it.

[rylo]

Hi

Can you please clarify the direction of copy. Are you copying from sheet1 column Q (or M or K whichever has data) to column D in DataPEs, or from DataPEs!D to Sheet1?

rylo

[eonizuka]

Hi Rylo,
The copy will be from Sheet1 to DataPEs. Thanks!

[rylo]

Hi

Here goes

Sub aaa()
  Dim OutSH As Worksheet, DataSH As Worksheet
  Set OutSH = Sheets("DataPEs")
  Set DataSH = Sheets("Sheet1")
  
  DataSH.Activate
  
  For Each ce In Range("F2:F" & Cells(Rows.Count, "F").End(xlUp).Row)
    If Not IsEmpty(ce) Then
      Set findit = OutSH.Range("B:B").Find(what:=ce.Value, lookat:=xlWhole)
      If Not findit Is Nothing Then
        'determine data column
        If Not IsEmpty(Cells(ce.Row + 1, "Q")) Then
          datacol = "Q"
        ElseIf Not IsEmpty(Cells(ce.Row + 1, "M")) Then
          datacol = "M"
        Else
          datacol = "K"
        End If
        i = 1
        While Not IsEmpty(ce.Offset(i, -3))
          Set rng = findit.Offset(1, 0).Resize(6, 1)
          Set findit2 = rng.Find(what:=Right(ce.Offset(i, -3).Value, Len(ce.Offset(i, -3).Value) - 3))
          If Not findit2 Is Nothing Then findit2.Offset(0, 2).Value = Cells(ce.Offset(i, 0).Row, datacol).Value
          i = i + 1
        Wend
      End If
    End If
  Next ce
End Sub

rylo

[eonizuka]

Thanks for your time and help with this Rylo. If you don't mind would you walk me through your code, especially the Do While Not part of it.

[rylo]

Hi

I've put some more comments into the code. See if that helps. Don't hesitate to ask questions tho...

Sub aaa()
  'create and set aliases for the relevant sheets
  Dim OutSH As Worksheet, DataSH As Worksheet
  Set OutSH = Sheets("DataPEs")
  Set DataSH = Sheets("Sheet1")
  'activate the sheet with data
  DataSH.Activate
  
  'cycle through each item in the data sheet
  For Each ce In Range("F2:F" & Cells(Rows.Count, "F").End(xlUp).Row)
  'find a non blank data sheet cell
    If Not IsEmpty(ce) Then
    'do a find to see if the item exists in the output sheet
      Set findit = OutSH.Range("B:B").Find(what:=ce.Value, lookat:=xlWhole)
    'if the item is found
      If Not findit Is Nothing Then
        'determine data column by getting the lastmost data column
        If Not IsEmpty(Cells(ce.Row + 1, "Q")) Then
          datacol = "Q"
        ElseIf Not IsEmpty(Cells(ce.Row + 1, "M")) Then
          datacol = "M"
        Else
          datacol = "K"
        End If
        'initialise a loop counter
        i = 1
        'loop through the items in column C and find where they exist in the output sheet
        While Not IsEmpty(ce.Offset(i, -3))
        'set a range to search for the column C sub items
          Set rng = findit.Offset(1, 0).Resize(6, 1)
        'do a find rng to see if the sub item exists
          Set findit2 = rng.Find(what:=Right(ce.Offset(i, -3).Value, Len(ce.Offset(i, -3).Value) - 3))
        'if the sub item exists, then paste in the data
          If Not findit2 Is Nothing Then findit2.Offset(0, 2).Value = Cells(ce.Offset(i, 0).Row, datacol).Value
        'increment the counter
          i = i + 1
        Wend
      End If
    End If
  Next ce
End Sub

rylo