Matching data from two colums on separate sheets, and copying rows of matches to sheet 3

[jukurit]

I have information on two sheets. Sheets 1 and 2. I need to mach the data in sheet 1 column C with data in sheet 2 column P. If the numbers match i need the row in sheet 2 that has the matching number to be copied into sheet 3. (there are multiple numbers that match in sheet 2 and i set by sheet 1)
Suggestions please?

 

[Sektor]

What data and where must be searched?
1. Data of "Yritys" sheet in "Yhteyshenkilo" sheet.
1. Data of "Yhteyshenkilo" sheet in "Yritys" sheet.

 

[jukurit]

they are numbers.
the numbers in yritys column C that match with numbers in yhteyshenkilo column P.
If the number is found in yhteyshenkilo column P i need that rown with the number and the rest of the information to be copied into Valmis.

There are 13000 thousand contacts so i really dont want to go through them manually.

 

[Sektor]

Sub Collect()

    Dim sh As Worksheet
    Dim rng1 As Range, rng2 As Range, cell As Range
    
    Set sh = Sheets("Valmis")
    
    With Sheets("Yritys")
        Set rng1 = .Range("C1", .Range("C1").End(xlDown))
    End With
    With Sheets("Yhteyshenkilo")
        Set rng2 = .Range("P1", .Range("P1").End(xlDown))
    End With
    
    For Each cell In rng1
        If WorksheetFunction.CountIf(rng2, cell.Value) Then
            sh.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0) = cell.Value
        End If
    Next

End Sub

JackDanIce, what's the point of copying and pasting?

 

[jukurit]

Now i only received the numbers.
So content in column P, i need the whole row. as a copy.

 

[Sektor]

Sub Collect()

    Dim sh As Worksheet
    Dim rng1 As Range, rng2 As Range, cell As Range
    
    Set sh = Sheets("Valmis")
    
    With Sheets("Yritys")
        Set rng1 = .Range("C1", .Range("C1").End(xlDown))
    End With
    With Sheets("Yhteyshenkilo")
        Set rng2 = .Range("P1", .Range("P1").End(xlDown))
    End With
    
    For Each cell In rng1
        If WorksheetFunction.CountIf(rng2, cell.Value) Then
            cell.EntireRow.Copy sh.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
        End If
    Next

End Sub

 

[JackDanIce]

His original question asked for the entire row to be copied over when a match was found as does his question header indicate - assumed that's what was wanted.

 

[jukurit]

Ok.
Now it copied the rows from Yrutys (Sheet 1) instead of Yhteyshenkilo (Sheet 2)

Anyway the switch it around?

Getting close.

Thanks for all the help in advance. Really appreciate it!

 

[JackDanIce]

Try:

Sub Collect()

    Dim sh As Worksheet
    Dim rng1 As Range, rng2 As Range, cell As Range
    
    Set sh = Sheets("Valmis")
    
    With Sheets("Yritys")
        Set rng1 = .Range("C1", .Range("C1").End(xlDown))
    End With
    With Sheets("Yhteyshenkilo")
        Set rng2 = .Range("P1", .Range("P1").End(xlDown))
    End With
    
    For Each cell In rng2
        If WorksheetFunction.CountIf(rng1, cell.Value) Then
            cell.EntireRow.Copy sh.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
        End If
    Next

End Sub

 

[jukurit]

now it copies the right data.

however it stays on one row. so all the data goes through on the same row. any way to make it so it shifts down a row for each contact

 

[JackDanIce]

Does this work:

Sub Collect()
    Dim sh As Worksheet
    Dim rng1 As Range, rng2 As Range, cell As Range
 
    Set sh = Sheets("Valmis")
 
    With Sheets("Yritys")
        Set rng1 = .Range("C1", .Range("C1").End(xlDown))
    End With
    With Sheets("Yhteyshenkilo")
        Set rng2 = .Range("P1", .Range("P1").End(xlDown))
    End With
 
    For Each cell In rng2
        If WorksheetFunction.CountIf(rng1, cell.Value) Then
            cell.EntireRow.Copy
            sh.Cells(Rows.Count, 16).End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlValues
        End If
    Next
End Sub