Looking for a bit of VBA help (Duplicate finding/ differences).

[MiniFav]

I am currently trying to create a spreadsheet which will capture various information

Request 1
Column B is for part numbers.
Column C is for serial numbers.
I can have many of the same part numbers but there should never be a duplicate serial number for a single part number.
I may often have the same serial numbers across multiple part numbers though.
I would like these serial number duplicates to be highlighted along with the relevant part number, and if possible return to the default colour when corrected on the page.

Request 2
Column B for the part numbers
Column D for descriptions.
Part numbers should always have the same descriptions. I would like any differences highlighted, and again format returned to default if corrected.

I have this kind of working from various codes from across the internet, however i am finding the loop stops if it encounters a blank cell or that if i correct one description to match another then all the other differences for said part number get cleared too.

OCCMTemplate - test.xlsm
	B	C	D
1	PartNo*	SerialNo*	PartDescription*
2	ABC123	456	Tool
3	ABC123	322	Tool
4	ABC123	654	Tools
5	ABC123	456	Tool
6	DEF456	322	Screw
7	DEF456	320	Screws
8	DEF456	321	Screw
9	DEF456	321	Bolt
10	DEF456	123	Screw
Sheet1

This is the code i have so far (sorry for the state of it).

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

       Dim compRow As Integer, rowNo As Integer

       'Get the last row of data
       lastRow = Worksheets("sheet1").Cells(Rows.Count, 2).End(xlUp).Row

       'Loop through all the rows
      For rowNo = 2 To lastRow

          'For each rowNo, loop through all the remaining rows
          For compRow = rowNo + 1 To lastRow
          

                    
'CORRECTED PN AND SN DUPES'

              'Check if a match is found in Column B for the current rowNo
              If Range("B" & compRow) = Range("B" & rowNo) Then


                  'If a match is found in Column B, check correspoding values of column C
                  If Range("C" & compRow) <> Range("C" & rowNo) Then

                                'Duplicate data accross 3 columns found. Highlight both the rows
                          Range("B" & compRow & ":C" & compRow).Interior.Color = xlNone
                          Range("B" & rowNo & ":C" & rowNo).Interior.Color = xlNone
                          
                    
                          
                          Else
                          
                        If Not Range("B" & compRow & ":B" & compRow).Value = vbNullString And Not Range("B" & compRow & ":B" & compRow).Interior.Color = xlNone Then
                         
                              'Duplicate data accross 3 columns found. Highlight both the rows
                          Range("B" & compRow & ":C" & compRow).Interior.Color = vbYellow
                          Range("B" & rowNo & ":C" & rowNo).Interior.Color = vbYellow
                          
                         
                          End If
                                                 
                    End If
                    
               'End If
                                    

               
'RESTORE CORRECTED TO DEFAULT COLOUR'
               
               'Check if a match is found in Column B for the current rowNo
              If Range("B" & compRow) = Range("B" & rowNo) Then
                        
                        
                            'If a match is found in Columns A and B, check correspoding values of column D
                      If Range("D" & compRow) = Range("D" & rowNo) Then

                          'Duplicate data accross columns found. Highlight both the rows
                          
                          Range("D" & compRow & ":D" & compRow).Interior.Color = xlNone
                          Range("D" & rowNo & ":D" & rowNo).Interior.Color = xlNone
                          
                         Else
                          
                                           
                          'Different data accross columns found. Highlight both the rows
                          Range("D" & compRow & ":D" & compRow).Interior.Color = vbRed
                          Range("D" & rowNo & ":D" & rowNo).Interior.Color = vbRed
                          
                    
                  End If
                          
              End If
              
                          
        End If
                            
                  
          Next compRow
      Next rowNo

End Sub

 

[rlv01]

One way.

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim Rng As Range, R As Range
    Dim SD1 As Object, SD2 As Object
    Dim KeyStr As String, RefStr As String

   'Define range for part number column "B"
    Set Rng = Me.Range("B2:B" & Me.Range("B" & Me.Rows.Count).End(xlUp).Row)

    Set SD1 = CreateObject("Scripting.dictionary")    'for S/N check
    Set SD2 = CreateObject("Scripting.dictionary")    'for desc check

    'RESTORE TO DEFAULT COLOUR'
    Rng.Resize(, 3).Interior.Color = xlNone

    For Each R In Rng
        'HIGHLIGHT PN AND SN DUPES'
        KeyStr = R.Value & ":" & R.Offset(0, 1).Value    'Search Key stored in dictionary
        If Not SD1.Exists(KeyStr) Then                'Unique key value, not already in the dictionary
            SD1.Add KeyStr, vbNullString
        Else
            R.Resize(, 2).Interior.Color = vbYellow   'highlight duplicate P/N + S/N
        End If

        'HIGHLIGHT DIFFENT DESCRIPTIONS FOR SAME PN
        KeyStr = R.Value                              'Search Key stored in dictionary
        If Not SD2.Exists(KeyStr) Then                'Unique key value, not already in the dictionary
            SD2.Add KeyStr, R.Offset(0, 2).Value
        Else
            RefStr = SD2(KeyStr)
            If R.Offset(0, 2).Value <> RefStr Then
                R.Offset(0, 2).Interior.Color = vbRed    'highlight different Desc
            End If
        End If
    Next R
    Set SD1 = Nothing
    Set SD2 = Nothing
End Sub

 

[MiniFav]

Wow that was quick, than you for the response.

I have tried your code.

I am currently seeing row 2 is not being picked up as a duplicate.
Also the part description check is not highlighting the test, so I may not know which input is right at this point i would need rows 1,2,5 and 6 highlighted.

OCCMTemplate - test.xlsm
	B	C	D
1	PartNo*	SerialNo*	PartDescription*
2	123	321	test
3	123	321	test
4	456	654
5	123	321
6	123	321
Sheet1

thank you for all your help!

 

[rlv01]

<<at this point i would need rows 1,2,5 and 6 highlighted. >>

Are you saying you want to highlight row 1 (the header row)?

 

[MiniFav]

<<at this point i would need rows 1,2,5 and 6 highlighted. >>

Are you saying you want to highlight row 1 (the header row)?

Sorry, I meant 2,3,5 and 6 (any with "123" as the value for example).

 

[rlv01]

This might work more like you want.

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim Rng As Range, R As Range
    Dim SD1 As Object, SD2 As Object
    Dim KeyStr As String, RefStr As String
    Dim WS As Worksheet

    Set WS = Me
    Set SD1 = CreateObject("Scripting.dictionary")    'for S/N check
    Set SD2 = CreateObject("Scripting.dictionary")    'for description check

    'Define range for part number column "B"
    Set Rng = WS.Range("B2:B" & WS.Range("B" & WS.Rows.Count).End(xlUp).Row)

    Rng.Resize(, 3).Interior.Color = xlNone

    'Find instances
    For Each R In Rng
        KeyStr = R.Value
        If Not SD1.Exists(KeyStr) Then
            SD1.Add KeyStr, R.Offset(0, 1).Value
        Else
            RefStr = SD1(KeyStr)
            If (RefStr <> R.Offset(0, 1).Value) Then
                SD1(KeyStr) = RefStr & "," & R.Offset(0, 1).Value
            End If
        End If

        KeyStr = R.Value
        If Not SD2.Exists(KeyStr) Then
            SD2.Add KeyStr, R.Offset(0, 2).Value
        Else
            RefStr = SD2(KeyStr)
            If (RefStr <> R.Offset(0, 2).Value) And (Trim(R.Offset(0, 2).Value) <> "") Then
                SD2(KeyStr) = RefStr & "," & R.Offset(0, 2).Value
            End If
        End If
    Next R

    'Highlight cells
    For Each R In Rng

        KeyStr = R.Value
        If SD1.Exists(KeyStr) Then
            RefStr = SD1(KeyStr)
            If UBound(Split(RefStr, ",")) > 0 Then
                R.Resize(, 2).Interior.Color = vbYellow    'highlight P/Ns with the same S/N
            End If
        End If

        If Trim(R.Offset(0, 2).Value) = "" Then
            R.Offset(0, 2).Interior.Color = vbRed     'highlight any missing descriptions
        End If

        KeyStr = R.Value
        If SD2.Exists(KeyStr) Then
            RefStr = SD2(KeyStr)
            If UBound(Split(RefStr, ",")) > 0 Then
                R.Offset(0, 2).Interior.Color = vbRed    'highlight P/Ns with more than one description
            End If
        End If
    Next R

    Set SD1 = Nothing
    Set SD2 = Nothing
End Sub

 

[MiniFav]

Than you! this is sooo close.

It seems to be highlighting yellow when the serials are different and clearing when they are duplicate.
I'll try to reverse it and then it will be perfect!

OCCMTemplate - test.xlsm
	B	C	D
1	PartNo*	SerialNo*	PartDescription*
2	123	A1	test
3	123	A2	test
4	456	654	Spoon
5	123	A2	test
6	123	A4	test
7	456	653	Spoons
8	789	C2
9	789	C2
10
11	789	C2
Sheet1

you are a gentleman and a scholar!

 

[MiniFav]

Sorry to be a nuisance.

I have reversed the issued i had prior.

I have noticed that if just one serial get changed to be different then all the other duplicates lose their highlight. Could you help with this?

OCCMTemplate - test.xlsm
	B	C	D
1	PartNo*	SerialNo*	PartDescription*
2	1	2
3	1	2
4
5	1	2
6	1	1
Sheet1

 

[rlv01]

Actually, when any PN has more than one SN, then all col BC cells for that PN are highlighted. Make sure that all rows with PN ABC have the same SN and the highlighting goes away.

 

[MiniFav]

You are absolutely right!