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

 

[MiniFav]

Think I can demonstrate my last issue a bit better.

Below you can see all part numbers with value "123" and duplicate serial numbers.

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

Now if i correct just one to be different and not a duplicate, then all the other duplicates lose their highlight.

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

Is there a solution to this?

 

[rlv01]

Ok, this should highlight duplicates for PN + SN

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 = UCase(R.Value & ":" & R.Offset(0, 1).Value)
        If Not SD1.Exists(KeyStr) Then
            SD1.Add KeyStr, "1"
        Else
            RefStr = SD1(KeyStr)
            SD1(KeyStr) = "More than 1"
        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 = UCase(R.Value & ":" & R.Offset(0, 1).Value)
        If SD1.Exists(KeyStr) Then
            RefStr = SD1(KeyStr)
            If RefStr <> "1" 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