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

Dazzawm

Well-known Member
Joined
Jan 24, 2011
Messages
3,748
Office Version
  1. 365
Platform
  1. Windows
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
ADAE
1PartDescription
2TX1234Example
3TX1234Example
4TX1234Example 1
5TX1237Example 2
6TX1237Example 2
7TX1237Example 2
8TX1240Example 3
9TX1240Example 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
AB
1PartDescription
2TX1234Example
3TX1234Example
4TX1234Example 1
5TX1240Example 3
6TX1240Example 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.
 
Last edited:

Excel Facts

Which came first: VisiCalc or Lotus 1-2-3?
Dan Bricklin and Bob Frankston debuted VisiCalc in 1979 as a Visible Calculator. Lotus 1-2-3 debuted in the early 1980's, from Mitch Kapor.
How about
Code:
Sub CheckParts()

   Dim Dic As Object
   Dim Cl As Range
   Dim Ky As Variant
   Dim V1 As String, V2 As String
   
   Set Dic = CreateObject("scripting.dictionary")
   With Sheets("Sheet1")
      For Each Cl In .Range("A2", .Range("A" & Rows.Count).End(xlUp))
         V1 = Cl.Value: V2 = Cl.Offset(, 1).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
 
Upvote 0
Just one more thing please Fluff. If its not too difficult to add could what cell the mismatches are in be put in column C?
 
Upvote 0
Actually I am not sure if its going to be as easy as that. It will list 100s of one description and the same of a different one now. As it is it just lists the unique differences. Don't worry.
 
Upvote 0
If you want to know the original addresses, try
Code:
Private Sub Worksheet_Change(ByVal Target As Range)

   If Target.CountLarge > 1 Then Exit Sub
Application.EnableEvents = False
   Select Case Target.Column
      Case 2
         If Target.Value <> "" Then Intersect(Target.EntireRow, Range("A:A, I:I, L:L,Z:Z")).Value = Date
      Case 5
         If Target.Value <> "" Then Target.Offset(, 1).Resize(, 2).Value = Array("Walk In", "Endorsed to")
      Case 10
         If Target.Value <> "" Then Target.Offset(, 1).Value = "Go"
      Case 13
          If Target.Value <> "" Then Intersect(Target.EntireRow, Range("N:N, AA:AA")).Value = "No Go"
   End Select
Application.EnableEvents = True
End Sub
 
Upvote 0
Is this a separate macro I run after the first one?
 
Upvote 0
:oops: I seem to have copied the wrong code, try
Code:
Sub CheckParts()
   Dim Dic As Object
   Dim Cl As Range
   Dim Ky As Variant
   Dim V1 As String, V2 As String
   
   Set Dic = CreateObject("scripting.dictionary")
   With Sheets("Sheet1")
      For Each Cl In .Range("A2", .Range("A" & Rows.Count).End(xlUp))
         V1 = Cl.Value: V2 = Cl.Offset(, 1).Value
         If Not Dic.exists(V1) Then
            Dic.Add V1, CreateObject("scripting.dictionary")
            Dic(V1).Add V2, Cl.Address
         ElseIf Not Dic(V1).exists(V2) Then
            Dic(V1).Add V2, Cl.Address
         Else
            Dic(V1)(V2) = Dic(V1)(V2) & ", " & Cl.Address
         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)
            .Offset(, 2).Resize(Dic(Ky).Count).Value = Application.Transpose(Dic(Ky).items)
         End With
      End If
   Next Ky
End Sub
 
Upvote 0
Thanks but that come up with a Type Mismatch error?
 
Upvote 0

Forum statistics

Threads
1,213,543
Messages
6,114,245
Members
448,555
Latest member
RobertJones1986

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top