Returns rows of matching columns

[biglifter]

Hi,

I'm looking for some code gurus to share some wisdom. Here's the situation:

I have 2 worksheets and both contain Last Name and First Name columns. What I'm trying to do is run some VBA code that would

> Check the Last and First name columns of sheet1
> Find matching Last and First name columns values in sheet2
> Return the entire rows of sheet2, for all matching values, in a new worksheet

Hopefully, that's clear as mud. Basically, if I find an entry for Smith, John in worksheet1 and another Smith, John in worksheet2, I want to returnall the information in the Smith, John row for worksheet2 (in a newly created table). Many thanks in advance!!

[StephenR]

Sounds like you might be able to use the VLOOKUP formula. Attach a small sample workbook if not.

[biglifter]

Attached.......

[Leith Ross]

Hello biglifter,

This macro has been added to the attaached workbook. There is button on the "Names" sheet to run the macro.

Sub CopyNamesAndData()

  Dim Cell As Range
  Dim DSO As Object
  Dim Key As Variant
  Dim Keys As Variant
  Dim Item As Variant
  Dim R As Long
  Dim Rng As Range
  Dim RngEnd As Range
  Dim InfoWks As Worksheet
  Dim NamesWks As Worksheet
  Dim SummaryWks As Worksheet
  
    R = 2
    Set InfoWks = Worksheets("Info")
    Set NamesWks = Worksheets("Names")
    Set SummaryWks = Worksheets("Sheet3")
    
    Set Rng = InfoWks.Range("A2")
    Set RngEnd = Rng.Parent.Cells(Rows.Count, Rng.Column).End(xlUp)
    Set Rng = IIf(RngEnd.Row < Rng.Row, Rng, Rng.Parent.Range(Rng, RngEnd))
    
    Set DSO = CreateObject("Scripting.Dictionary")
    DSO.CompareMode = vbTextCompare
    
      For Each Cell In Rng.Cells
        Key = Trim(Cell & Cell.Offset(0, 1))
        If Key <> "" Then
           If Not DSO.Exists(Key) Then
              DSO.Add Key, Cell
           End If
        End If
      Next Cell
      
      Set Rng = NamesWks.Range("A2")
      Set RngEnd = Rng.Parent.Cells(Rows.Count, Rng.Column).End(xlUp)
      Set Rng = IIf(RngEnd.Row < Rng.Row, Rng, Rng.Parent.Range(Rng, RngEnd))
      
      For Each Cell In Rng.Cells
        Key = Trim(Cell & Cell.Offset(0, 1))
        If Key <> "" Then
           If DSO.Exists(Key) Then
              DSO(Key).EntireRow.Copy SummaryWks.Cells(R, "A")
              R = R + 1
           End If
        End If
      Next Cell
      
    Set DSO = Nothing
    
End Sub

[biglifter]

Thank you!!!! Worked perfectly