Code To Look At Number In AD And If Any Descriptions Are Different In AE Then List Them On Sheet 2

[Dazzawm]

Hi. I need a code that will tell me if there are any descriptions that are different to a particular number. In the sample below you can see there is some data in AD. When the a number is found on sheet 1 and the description is different in AE anywhere else on the sheet then I need these copied to sheet 2 like the second example. Thanks.

Excel 2010

	AD	AE
1	Part	Description
2	TX1234	Example
3	TX1234	Example
4	TX1234	Example 1
5	TX1237	Example 2
6	TX1237	Example 2
7	TX1237	Example 2
8	TX1240	Example 3
9	TX1240	Example 4

<tbody>
</tbody>

Sheet1​

As you can see rows 5, 6 & 7 all match so they don't need copying, the others do because there are different descriptions to the same part number.
Excel 2010

	A	B
1	Part	Description
2	TX1234	Example
3	TX1234	Example
4	TX1234	Example 1
5	TX1240	Example 3
6	TX1240	Example 4

<tbody>
</tbody>

Sheet2​

I must add they will not be grouped together as above, the first number may be row 2 then not appear again until row 100,002 for example.

 

[Dazzawm]

If you mean column A in your code then no it won't. But it will be column AD as I said earlier.

 

[Fluff]

In that case try

Sub CheckParts()
   Dim Dic As Object
   Dim Cl As Range
   Dim Ky As Variant
   Dim V1 As String, V2 As String
   Dim Col2 As String
   
   Col2 = InputBox("Please enter the 2nd column")
   If Col2 = "" Then Exit Sub
   Set Dic = CreateObject("scripting.dictionary")
   With Sheets("Sheet1")
      For Each Cl In .Range("AD2", .Range("AD" & Rows.Count).End(xlUp))
         V1 = Cl.Value: V2 = .Cells(Cl.Row, Col2).Value
         If Not Dic.Exists(V1) Then
            Dic.Add V1, CreateObject("scripting.dictionary")
            Dic(V1).Add V2, Nothing
         ElseIf Not Dic(V1).Exists(V2) Then
            Dic(V1).Add V2, Nothing
         End If
      Next Cl
   End With
   For Each Ky In Dic.Keys
      If Dic(Ky).Count > 1 Then
         With Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Offset(1)
            .Resize(Dic(Ky).Count).Value = Ky
            .Offset(, 1).Resize(Dic(Ky).Count).Value = Application.Transpose(Dic(Ky).Keys)
         End With
      End If
   Next Ky
End Sub

 

[Dazzawm]

Perfect and thanks for your time Fluff.

 

[Fluff]

You're welcome & thanks for the feedback