Comparing cells which have common values in 2 different sheet tabs and pick the corresponding cells from sheet 2 to copy in 3rd sheet

[dharamsa]

Greetings,

Please find my scenario below,

I have emp id in sheet1 and sheet2

sheet1: sheet2:

empid name emp id name nominee
001 Jack 001 Jack Mary
002 Paul 001 Jack Toby
003 Mark 001 Jack Marianne
004 Steve 003 Mark Joanne
003 Mark Dave
004 Steve Sean
004 Steve Gerald
004 Steve Tabatha


I need to match empid in both sheets and if they match I want the cells empid, name and nominee copied to sheet3


I would be highly obliged if anybody could help me with this.

This is what I was trying,

[

Sub test()
Dim a, i As Long, ii As Integer, z As String
Dim n As Long, AB(), F_P(), x As Long, e
a = Sheet("Nominee").Range("a1").CurrentRegion.Resize(, 16).Value
ReDim AB(1 To UBound(a, 1), 1 To 2)
ReDim F_P(1 To UBound(a, 1), 1 To 11)
With CreateObject("Scripting.Dictionary")
.CompareMode = vbTextCompare
For i = 1 To UBound(a, 1)
z = a(i, 4) & ";" & a(i, 5)
If Not .exists(z) Then
n = n + 1
For ii = 1 To 13
If ii < 3 Then
AB(n, ii) = a(i, ii)
Else
F_P(n, ii - 2) = a(i, ii + 3)
End If
.Add z, n
End If
Next
a = Sheets("Employee").Range("a1").CurrentRegion.Resize(, 16).Value
For i = 1 To UBound(a, 1)
z = a(i, 4) & ";" & a(i, 5)
If .exists(z) Then
x = .Item(z)
For ii = 1 To 13
If ii < 3 Then
a(i, ii) = AB(x, ii)
Else
a(i, ii + 3) = F_P(x, ii - 2)
End If
Next
.Remove z
End If
Next
Sheets("Employee").Range("a1").CurrentRegion.Resize(, 16).Value = a
If .Count > 0 Then
ReDim a(1 To .Count, 1 To 16): n = 0
For Each e In .keys
x = .Item(e): n = n + 1
For ii = 1 To 13
If ii < 3 Then
a(n, ii) = AB(x, ii)
Else
a(n, ii + 3) = F_P(x, ii - 2)
End If
Next
Next
Sheets("Sheet4").Range("a" & Rows.Count).End(xlUp)(2) _
.Resize(n, 16).Value = a
End If
End With
End Sub

]



Best regards,

Jeff

 

[JLGWhiz]

Assuming that data is in columns A:B on sheet 1 and columns A:C on sheet 2

Sub fillsh3()
Dim sh1 As Worksheet, sh2 As Worksheet, sh3 As Worksheet, lr As Long, rng As Range, c As Range, Nm As Range
Set sh1 = Sheets(1) 'Edit sheet name
Set sh2 = Sheets(2) 'Edit sheet name
Set sh3 = Sheets(3) 'Edit sheet name
lr = sh1.Cells(Rows.Count, 1).End(xlUp).Row
Set rng = sh1.Range("A2:A" & lr)
    For Each c In rng
        Set Nm = sh2.Range("A:A").Find(c.Value, LookIn:=xlValues)
            If Not Nm Is Nothing Then
                fAdr = Nm.Address
                    Do
                        Nm.Resize(1, 3).Copy sh3.Cells(Rows.Count, 1).End(xlUp)(2)
                        Nm.Value = c.Value
                        Set Nm = sh2.Range("A:A").FindNext(Nm)
                    Loop While fAdr <> Nm.Address
            End If
    Next
End Sub

 

[dharamsa]

Thank you so much for the reply, appreciate it.

Actually the emp id is in column B of both sheet 1 and sheet 2 and the data that I want to be copied in sheet 3 is from column G to M in the sheet 2.

I would be really obliged if you could help me crack this one.


Thanks,

Jeff

 

[JLGWhiz]

This should work;

Sub fillsh3()
Dim sh1 As Worksheet, sh2 As Worksheet, sh3 As Worksheet, lr As Long, rng As Range, c As Range, Nm As Range
Set sh1 = Sheets(1) 'Edit sheet name
Set sh2 = Sheets(2) 'Edit sheet name
Set sh3 = Sheets(3) 'Edit sheet name
lr = sh1.Cells(Rows.Count, 2).End(xlUp).Row
Set rng = sh1.Range("B2:B" & lr)
    For Each c In rng
        Set Nm = sh2.Range("B:B").Find(c.Value, LookIn:=xlValues)
            If Not Nm Is Nothing Then
                fAdr = Nm.Address
                    Do
                        sh2.Range("G" & Nm.Row).Resize(1, 7).Copy sh3.Cells(Rows.Count, 1).End(xlUp)(2)
                        Nm.Value = c.Value
                        Set Nm = sh2.Range("B:B").FindNext(Nm)
                    Loop While fAdr <> Nm.Address
            End If
    Next
End Sub

It is helpful if details of the data locations are included in the original post.

 

[dharamsa]

Thank you very much, JLGWhiz. I will try and include all details in my future posts.

CHEERS!,

Jeff

 

[dharamsa]

Hey JLGWhiz,

Your code is working perfectly, just one modification I need.

Currently it is copying the first row that it is finding. I have multiple rows for 1 id.

So id - 0001 can have 4 rows of data.

Is there anyway that I can get all the rows associated with a single id to copy into sheet3?

Appreciate your help.


Thanks,

Jeff

 

[JLGWhiz]

Hey JLGWhiz,

Your code is working perfectly, just one modification I need.

Currently it is copying the first row that it is finding. I have multiple rows for 1 id.

So id - 0001 can have 4 rows of data.

Is there anyway that I can get all the rows associated with a single id to copy into sheet3?

Appreciate your help.


Thanks,

Jeff

I don't understand why you are not getting a return for each instance of the ID number in column B. In my test set up, I entered Unique Id numbers in column B, then entered several rows of duplicate Id numbers in column B of sheet 2. All the items on sheet two were returned on Sheet 3. However, On the chance that you have trailing or leading spaces in your column B entries on sheet 2 or sheet one, try this modified code.

Sub fillsh3()
Dim sh1 As Worksheet, sh2 As Worksheet, sh3 As Worksheet, lr As Long, rng As Range, c As Range, Nm As Range
Set sh1 = Sheets(1) 'Edit sheet name
Set sh2 = Sheets(2) 'Edit sheet name
Set sh3 = Sheets(3) 'Edit sheet name
lr = sh1.Cells(Rows.Count, 2).End(xlUp).Row
Set rng = sh1.Range("B2:B" & lr)
    For Each c In rng
        Set Nm = sh2.Range("B:B").Find(Trim(c.Value), LookIn:=xlValues, LookAt:=xlPart)
            If Not Nm Is Nothing Then
                fAdr = Nm.Address
                    Do
                        sh2.Range("G" & Nm.Row).Resize(1, 7).Copy sh3.Cells(Rows.Count, 1).End(xlUp)(2)
                        Nm.Value = Trim(c.Value)
                        Set Nm = sh2.Range("B:B").FindNext(Nm)
                    Loop While fAdr <> Nm.Address
            End If
    Next
End Sub