On demand macro to look for inconsistent data

L

Lux Aeterna

Board Regular
Joined
Aug 27, 2015
Messages
205
Office Version
  1. 2019
Platform
  1. Windows
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 🤞

1674665432056.png
 

Excel Facts

Bring active cell back into view
Start at A1 and select to A9999 while writing a formula, you can't see A1 anymore. Press Ctrl+Backspace to bring active cell into view.
Sort by date Sort by votes
First, it will take very long to accomplish 10000 rows for each sheet.
Beside this, one question: How about write the log in pairs? Old value, conflicting value, old value, conflicting value?
One more question, let's say, it found Kenny McCormik again with 12345 in List2024. Is it count as conflict when it finds out it is the duplicate of Stan Marsh in List2023? If not, then how the code will know 12345 is uniquely assigned for Kenny McCormik?
 
Upvote 0
Thanks for your reply!

Flashbond said:
One more question, let's say, it found Kenny McCormik again with 12345 in List2024. Is it count as conflict when it finds out it is the duplicate of Stan Marsh in List2023? If not, then how the code will know 12345 is uniquely assigned for Kenny McCormik?
Click to expand...
If we find an inconsistent value, we will correct it. So, we'll assign a new code to Stan Marsh and that same inconsistency won't come up again.

Flashbond said:
Beside this, one question: How about write the log in pairs? Old value, conflicting value, old value, conflicting value?
Click to expand...
I'm not sure what you mean, but if you think it's easier for you and lighter for the file I'm open to it.

I'm also open to other ideas, if you think they'll work better. I've got a limited knowledge of excel capabilities.
 
Upvote 0
I started to code in a very efficient way but it turned out in a total mess. Please let me know if it runs too slow. Please find the sample project file and the code below:
we.tl

Proje.xlsm

1 file sent via WeTransfer, the simplest way to send your files around the world
we.tl we.tl
VBA Code: 
Sub test()
  Dim wSheets() As Variant, tmpArr As Variant, tmpArr2 As Variant, results() As Variant, codes As Dictionary, k As Long, c As Long, u As Long
  ReDim results(0 To 0)
  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, 2) = j
        wSheets(i)(j, 4) = Worksheets(i).Name
      Next
      End With
    End If
  Next
  Application.ScreenUpdating = False
  With Worksheets("Stats")
  For Each wSheet In wSheets
    For i = 2 To UBound(wSheet)
      If Not codes.Exists(wSheet(i, 5)) Then
        codes.Add wSheet(i, 5), 1
        For Each ws In wSheets
          tmpArr = Filter2DArray(ws, 5, wSheet(i, 5))
          If Not IsEmpty(tmpArr) Then
            tmpArr2 = Filter2DArray(tmpArr, 3, wSheet(i, 3))
            If IsEmpty(tmpArr2) Then
              u = 0
            Else
              u = UBound(tmpArr2)
            End If
            If UBound(tmpArr) <> u Then
                .Cells(Rows.Count, 2).End(xlUp).Offset(1).Value = wSheet(i, 1)
                .Cells(Rows.Count, 3).End(xlUp).Offset(1).Value = wSheet(i, 3)
                .Cells(Rows.Count, 1).End(xlUp).Offset(1).Value = wSheet(i, 4)
                .Cells(Rows.Count, 6).End(xlUp).Offset(1).Value = wSheet(i, 5)
                k = 1
                c = k
                For Each temp In tmpArr
                  Select Case c
                  Case 1
                  .Cells(Rows.Count, 2).End(xlUp).Offset(1).Value = temp
                  Case 3
                  .Cells(Rows.Count, 3).End(xlUp).Offset(1).Value = temp
                  Case 4
                  .Cells(Rows.Count, 1).End(xlUp).Offset(1).Value = temp
                  Case 5
                  .Cells(Rows.Count, 6).End(xlUp).Offset(1).Value = temp
                  End Select
                  If k Mod UBound(tmpArr) = 0 Then
                    c = c + 1
                  End If
                  k = k + 1
                Next
              End If
           ' End If
          End If
        Next
      End If
    Next
  Next
  End With
  Application.ScreenUpdating = True
  If Worksheets("Stats").Cells(Rows.Count, 1).End(xlUp).Row = 1 Then
    MsgBox "No Conflict found!"
  End If
End Sub
Function Filter2DArray(ByVal sArray, ByVal ColIndex As Long, ByVal FindStr As String)
  Dim tmpArr, i As Long, j As Long, Arr, Dic, TmpStr, Tmp, Chk As Boolean, TmpVal As Double
  On Error Resume Next
  Set Dic = CreateObject("Scripting.Dictionary")
  tmpArr = sArray
  ColIndex = ColIndex + LBound(tmpArr, 2) - 1
  Chk = (InStr("><=", Left(FindStr, 1)) > 0)
  For i = LBound(tmpArr, 1) To UBound(tmpArr, 1)
    If Chk Then
      TmpVal = CDbl(tmpArr(i, ColIndex))
      If Evaluate(TmpVal & FindStr) Then Dic.Add i, ""
    Else
      If UCase(tmpArr(i, ColIndex)) Like UCase(FindStr) Then Dic.Add i, "" 'This finds only exact matches, if you need *FindStr* use:  If UCase(tmpArr(i, ColIndex)) Like UCase("*" & FindStr & "*") Then Dic.Add i, ""

    End If
  Next
  If Dic.Count > 0 Then
    Tmp = Dic.Keys
    ReDim Arr(LBound(tmpArr, 1) To UBound(Tmp) + LBound(tmpArr, 1), LBound(tmpArr, 2) To UBound(tmpArr, 2))
    For i = LBound(tmpArr, 1) To UBound(Tmp) + LBound(tmpArr, 1)
      For j = LBound(tmpArr, 2) To UBound(tmpArr, 2)
        Arr(i, j) = tmpArr(Tmp(i - LBound(tmpArr, 1) + HasTitle), j)
      Next
    Next
  End If
  Filter2DArray = Arr
End Function
Don't forget to reference Microsoft Scripting Runtime in the VBE / Tools / Options - to enable Dictionaries.
 
Upvote 0
Flashbond said:
I started to code in a very efficient way but it turned out in a total mess. Please let me know if it runs too slow. Please find the sample project file and the code below:
we.tl

Proje.xlsm

1 file sent via WeTransfer, the simplest way to send your files around the world
we.tl we.tl
VBA Code: 
Sub test()
  Dim wSheets() As Variant, tmpArr As Variant, tmpArr2 As Variant, results() As Variant, codes As Dictionary, k As Long, c As Long, u As Long
  ReDim results(0 To 0)
  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, 2) = j
        wSheets(i)(j, 4) = Worksheets(i).Name
      Next
      End With
    End If
  Next
  Application.ScreenUpdating = False
  With Worksheets("Stats")
  For Each wSheet In wSheets
    For i = 2 To UBound(wSheet)
      If Not codes.Exists(wSheet(i, 5)) Then
        codes.Add wSheet(i, 5), 1
        For Each ws In wSheets
          tmpArr = Filter2DArray(ws, 5, wSheet(i, 5))
          If Not IsEmpty(tmpArr) Then
            tmpArr2 = Filter2DArray(tmpArr, 3, wSheet(i, 3))
            If IsEmpty(tmpArr2) Then
              u = 0
            Else
              u = UBound(tmpArr2)
            End If
            If UBound(tmpArr) <> u Then
                .Cells(Rows.Count, 2).End(xlUp).Offset(1).Value = wSheet(i, 1)
                .Cells(Rows.Count, 3).End(xlUp).Offset(1).Value = wSheet(i, 3)
                .Cells(Rows.Count, 1).End(xlUp).Offset(1).Value = wSheet(i, 4)
                .Cells(Rows.Count, 6).End(xlUp).Offset(1).Value = wSheet(i, 5)
                k = 1
                c = k
                For Each temp In tmpArr
                  Select Case c
                  Case 1
                  .Cells(Rows.Count, 2).End(xlUp).Offset(1).Value = temp
                  Case 3
                  .Cells(Rows.Count, 3).End(xlUp).Offset(1).Value = temp
                  Case 4
                  .Cells(Rows.Count, 1).End(xlUp).Offset(1).Value = temp
                  Case 5
                  .Cells(Rows.Count, 6).End(xlUp).Offset(1).Value = temp
                  End Select
                  If k Mod UBound(tmpArr) = 0 Then
                    c = c + 1
                  End If
                  k = k + 1
                Next
              End If
           ' End If
          End If
        Next
      End If
    Next
  Next
  End With
  Application.ScreenUpdating = True
  If Worksheets("Stats").Cells(Rows.Count, 1).End(xlUp).Row = 1 Then
    MsgBox "No Conflict found!"
  End If
End Sub
Function Filter2DArray(ByVal sArray, ByVal ColIndex As Long, ByVal FindStr As String)
  Dim tmpArr, i As Long, j As Long, Arr, Dic, TmpStr, Tmp, Chk As Boolean, TmpVal As Double
  On Error Resume Next
  Set Dic = CreateObject("Scripting.Dictionary")
  tmpArr = sArray
  ColIndex = ColIndex + LBound(tmpArr, 2) - 1
  Chk = (InStr("><=", Left(FindStr, 1)) > 0)
  For i = LBound(tmpArr, 1) To UBound(tmpArr, 1)
    If Chk Then
      TmpVal = CDbl(tmpArr(i, ColIndex))
      If Evaluate(TmpVal & FindStr) Then Dic.Add i, ""
    Else
      If UCase(tmpArr(i, ColIndex)) Like UCase(FindStr) Then Dic.Add i, "" 'This finds only exact matches, if you need *FindStr* use:  If UCase(tmpArr(i, ColIndex)) Like UCase("*" & FindStr & "*") Then Dic.Add i, ""

    End If
  Next
  If Dic.Count > 0 Then
    Tmp = Dic.Keys
    ReDim Arr(LBound(tmpArr, 1) To UBound(Tmp) + LBound(tmpArr, 1), LBound(tmpArr, 2) To UBound(tmpArr, 2))
    For i = LBound(tmpArr, 1) To UBound(Tmp) + LBound(tmpArr, 1)
      For j = LBound(tmpArr, 2) To UBound(tmpArr, 2)
        Arr(i, j) = tmpArr(Tmp(i - LBound(tmpArr, 1) + HasTitle), j)
      Next
    Next
  End If
  Filter2DArray = Arr
End Function
Don't forget to reference Microsoft Scripting Runtime in the VBE / Tools / Options - to enable Dictionaries.
Click to expand...
Thank you very much! Hopefully I'll have the time to check it tomorrow at work!
 
Upvote 0
A slightly "better" version:
we.tl

Project Final.xlsm

1 file sent via WeTransfer, the simplest way to send your files around the world
we.tl we.tl
VBA Code: 
Sub test()
  Dim wSheets() As Variant, tmpArr As Variant, tmpArr2 As Variant, codes As Dictionary, u As Long, written 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) = Worksheets(i).Name
      Next
      End With
    End If
  Next
  Application.ScreenUpdating = False
  With Worksheets("Stats")
  For Each wSheet In wSheets
    written = False
    For i = 2 To UBound(wSheet)
      If Not codes.Exists(wSheet(i, 5)) Then
        codes.Add wSheet(i, 5), 1
        For Each ws In wSheets
          tmpArr = Filter2DArray(ws, 5, wSheet(i, 5))
          If Not IsEmpty(tmpArr) Then
            tmpArr2 = Filter2DArray(tmpArr, 3, wSheet(i, 3))
            u = 0
            On Error Resume Next
            u = UBound(tmpArr2)
            On Error GoTo 0
          If UBound(tmpArr) <> u Then
            If tmpArr(1, 3) <> wSheet(i, 3) And Not written Then
              ReDim Preserve results(1 To 2)
              .Cells(Rows.Count, 2).End(xlUp).Offset(1).Value = wSheet(i, 1)
              .Cells(Rows.Count, 3).End(xlUp).Offset(1).Value = wSheet(i, 3)
              .Cells(Rows.Count, 1).End(xlUp).Offset(1).Value = wSheet(i, 4)
              .Cells(Rows.Count, 6).End(xlUp).Offset(1).Value = wSheet(i, 5)
              written = True
              End If
              For c = 1 To UBound(tmpArr)
                For r = 1 To 5
                  Select Case r
                  Case 1
                  .Cells(Rows.Count, 2).End(xlUp).Offset(1).Value = tmpArr(c, r)
                  Case 3
                  .Cells(Rows.Count, 3).End(xlUp).Offset(1).Value = tmpArr(c, r)
                  Case 4
                  .Cells(Rows.Count, 1).End(xlUp).Offset(1).Value = tmpArr(c, r)
                  Case 5
                  .Cells(Rows.Count, 6).End(xlUp).Offset(1).Value = tmpArr(c, r)
                  End Select
                Next
              Next
            End If
          End If
        Next
      End If
    Next
  Next
  End With
  Application.ScreenUpdating = True
  If Worksheets("Stats").Cells(Rows.Count, 1).End(xlUp).Row = 1 Then
    MsgBox "No Conflict found!"
  End If
End Sub
Function Filter2DArray(ByVal sArray, ByVal ColIndex As Long, ByVal FindStr As String)
  Dim tmpArr, i As Long, j As Long, Arr, Dic, TmpStr, Tmp, Chk As Boolean, TmpVal As Double
  On Error Resume Next
  Set Dic = CreateObject("Scripting.Dictionary")
  tmpArr = sArray
  ColIndex = ColIndex + LBound(tmpArr, 2) - 1
  Chk = (InStr("><=", Left(FindStr, 1)) > 0)
  For i = LBound(tmpArr, 1) To UBound(tmpArr, 1)
    If Chk Then
      TmpVal = CDbl(tmpArr(i, ColIndex))
      If Evaluate(TmpVal & FindStr) Then Dic.Add i, ""
    Else
      If UCase(tmpArr(i, ColIndex)) Like UCase(FindStr) Then Dic.Add i, "" 'This finds only exact matches, if you need *FindStr* use:  If UCase(tmpArr(i, ColIndex)) Like UCase("*" & FindStr & "*") Then Dic.Add i, ""

    End If
  Next
  If Dic.Count > 0 Then
    Tmp = Dic.Keys
    ReDim Arr(LBound(tmpArr, 1) To UBound(Tmp) + LBound(tmpArr, 1), LBound(tmpArr, 2) To UBound(tmpArr, 2))
    For i = LBound(tmpArr, 1) To UBound(Tmp) + LBound(tmpArr, 1)
      For j = LBound(tmpArr, 2) To UBound(tmpArr, 2)
        Arr(i, j) = tmpArr(Tmp(i - LBound(tmpArr, 1) + HasTitle), j)
      Next
    Next
  End If
  Filter2DArray = Arr
End Function
 
Upvote 0
The second one gives me this error. The first works fine, but only in your excel file. When I move the sheet in my file, it gives me a type mismatch error.

1674816134511.png
 
Last edited:
Upvote 0
Flashbond said:
I can make no comment without seeng the file.
Click to expand...
I think I found out the problem. There are a couple of other sheets in the workbook that I thought they weren't worth mentioning. The first one is called Test, the other one is called Results and in the future I might add some more, depending on our needs. Now that I deleted them the macro is running. It does take some time though (at the moment file is not responding)!

Update. Macro ended and fetched all the entries from the two List sheets, not only inconsistent ones, and at the end of these some other random results, among which there's only one inconsistent set. Moreover, there's an ID issue. If the ID on the list is 2, the fetched results give me 1 as ID.
 
Upvote 0
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?
 
Upvote 0
You must log in or register to reply here.

Similar threads

L
  • Question Question
Macro to correct entries across multiple sheets
Replies
1
Views
210
Lux Aeterna
L
ChrisMac1
  • Question Question
VBA - Compare specific data in one column on one sheet, with the same column on 4 other sheets, copy specific cells if match found.
Replies
1
Views
438
ChrisMac1
ChrisMac1
B
  • Question Question
Macro to Assign "UniqueID's" to Judges tables for a competition
Replies
1
Views
341
BeerMan23
B
K
  • Solved
Update to existing Move data macro
2
Replies
11
Views
746
Alex Blakenburg
A
S
  • Question Question
VBA Code- finding #Spill and moving the formula to the next column
Replies
0
Views
831
stromnoexcel
S

Forum statistics

Threads
1,224,824
Messages
6,181,187
Members
453,020
Latest member
Mohamed Magdi Tawfiq Emam

Share this page

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