On demand macro to look for inconsistent data

[Lux Aeterna]

Hello everyone!

There's a worksheet with 3 sheets. Stats, List2022, List2023 and more to be added every year (List2024 etc.) In the List* sheets, column C5:C10033 contains a name and column E5:E10033 contains a unique for each person number. The same person might appear more than once in each sheet, but their number remains the same

I am looking for a macro that checks if that number in column E is accidentally assigned to two different persons.

For example, in List2022, C380 is Kenny McCormick and his unique number in E380 is 12345. I'd like the macro to find if the number 12345 is assigned to another name in any of the List* sheets.

I'd like the macro to fetch inconsistent results in sheet Stats, starting from A37 (name of the sheet the inconsistent data was found), B37 (data from the corresponding row of column A of that sheet), C37 (data from the corresponding row of column C of that sheet), F37 (data from the corresponding row of column E of that sheet). If no inconsistent results is found, a pop up message saying everything is ok would be great.
I think it'd be better if the macro run on demand, to prevent overloading.

Hope that's not too much trouble

 

[Lux Aeterna]

One question, let's say you have 585 Kenny McCormick 12345 and 9752 Kenny McCormick 12345 only but no 4 Stan Marsh 12345.
Do you still want to see Kenny McCormicks only?

I am not sure I have got it right. Are you asking about the case a name (Column C) has two different codes (Column E)? If yes, no! I only need to know if the code has been assigned to more than one names.

 

[Legacy 143009]

This revision works perfectly for me. I hope it will be the same for you. I am not sure about the performance tough
Try:

Sub test()
  Dim wSheets() As Variant, codes As Dictionary, results() As Variant, lRow As Long, written As Boolean, other As Boolean
  Set codes = New Dictionary

  For i = 1 To Worksheets.Count
    If Left(Worksheets(i).Name, 4) = "List" Then
      With Worksheets(i)
      ReDim Preserve wSheets(1 To i)
      wSheets(i) = .UsedRange.Cells
      For j = 1 To .UsedRange.Rows.Count
        wSheets(i)(j, 4) = .Name
      Next
      End With
    End If
  Next
  
  ReDim results(1 To 1)
  With Application
  For w = 1 To UBound(wSheets)
    For i = 2 To UBound(wSheets(w))
      written = False
      If Not codes.Exists(wSheets(w)(i, 5)) Then
        codes.Add wSheets(w)(i, 5), 1
        For s = w To UBound(wSheets)
          For j = IIf(w = s, i + 1, 2) To UBound(wSheets(s))
            If wSheets(s)(j, 5) = wSheets(w)(i, 5) Then
              If Not written Then
                results(UBound(results)) = .Index(wSheets(w), i, 0)
                ReDim Preserve results(1 To UBound(results) + 1)
                written = True
              End If
              results(UBound(results)) = .Index(wSheets(s), j, 0)
              ReDim Preserve results(1 To UBound(results) + 1)
            End If
          Next
        Next
      End If
    Next
  Next
  ReDim Preserve results(1 To UBound(results) - 1)
  End With
  
  Application.ScreenUpdating = False
  lRow = 2
  With Worksheets("Stats")
  For i = 1 To UBound(results)
    other = False
    For j = i + 1 To UBound(results)
      If results(i)(5) = results(j)(5) Then
        If results(i)(3) <> results(j)(3) Then
          other = True
        End If
      Else
        j = j - 1
        Exit For
      End If
    Next
    If other = True Then
      For k = i To j
        .Cells(lRow, 1).Value = results(k)(4)
        .Cells(lRow, 2).Value = results(k)(1)
        .Cells(lRow, 3).Value = results(k)(3)
        .Cells(lRow, 6).Value = results(k)(5)
        lRow = lRow + 1
      Next
    End If
    i = j
  Next
  End With
  Application.ScreenUpdating = True
  If lRow = 2 Then
    MsgBox "No conflict found!"
  End If
End Sub

WeTransfer - Send Large Files & Share Photos Online - Up to 2GB Free

WeTransfer is the simplest way to send your files around the world

we.tl

 

[Lux Aeterna]

This revision works perfectly for me. I hope it will be the same for you. I am not sure about the performance tough
Try:

Sub test()
  Dim wSheets() As Variant, codes As Dictionary, results() As Variant, lRow As Long, written As Boolean, other As Boolean
  Set codes = New Dictionary

  For i = 1 To Worksheets.Count
    If Left(Worksheets(i).Name, 4) = "List" Then
      With Worksheets(i)
      ReDim Preserve wSheets(1 To i)
      wSheets(i) = .UsedRange.Cells
      For j = 1 To .UsedRange.Rows.Count
        wSheets(i)(j, 4) = .Name
      Next
      End With
    End If
  Next
 
  ReDim results(1 To 1)
  With Application
  For w = 1 To UBound(wSheets)
    For i = 2 To UBound(wSheets(w))
      written = False
      If Not codes.Exists(wSheets(w)(i, 5)) Then
        codes.Add wSheets(w)(i, 5), 1
        For s = w To UBound(wSheets)
          For j = IIf(w = s, i + 1, 2) To UBound(wSheets(s))
            If wSheets(s)(j, 5) = wSheets(w)(i, 5) Then
              If Not written Then
                results(UBound(results)) = .Index(wSheets(w), i, 0)
                ReDim Preserve results(1 To UBound(results) + 1)
                written = True
              End If
              results(UBound(results)) = .Index(wSheets(s), j, 0)
              ReDim Preserve results(1 To UBound(results) + 1)
            End If
          Next
        Next
      End If
    Next
  Next
  ReDim Preserve results(1 To UBound(results) - 1)
  End With
 
  Application.ScreenUpdating = False
  lRow = 2
  With Worksheets("Stats")
  For i = 1 To UBound(results)
    other = False
    For j = i + 1 To UBound(results)
      If results(i)(5) = results(j)(5) Then
        If results(i)(3) <> results(j)(3) Then
          other = True
        End If
      Else
        j = j - 1
        Exit For
      End If
    Next
    If other = True Then
      For k = i To j
        .Cells(lRow, 1).Value = results(k)(4)
        .Cells(lRow, 2).Value = results(k)(1)
        .Cells(lRow, 3).Value = results(k)(3)
        .Cells(lRow, 6).Value = results(k)(5)
        lRow = lRow + 1
      Next
    End If
    i = j
  Next
  End With
  Application.ScreenUpdating = True
  If lRow = 2 Then
    MsgBox "No conflict found!"
  End If
End Sub

WeTransfer - Send Large Files & Share Photos Online - Up to 2GB Free

WeTransfer is the simplest way to send your files around the world

we.tl

I still Type mismatch error. Error won't appear if I delete sheets that are not named List*