Using VBA to automate output for matching cell groups based on conditions

[Hammy123]

Hello. This is my first question here so apologies in advance for any mistakes or oversights.

I am working with a spreadsheet that contains ~10,000 rows of people's details. There are duplicate entries for each person (same surname, DOB etc.), but the postcodes are frequently different. Some entries for a group of people have a postcode For example like this:

A	B	C	D	E
ID	Last Name	DOB	Postcode	Comment
1	Solo	13/07/1942	SW11 5WS	Mismatch
2	Solo	13/07/1942		Mismatch
3	Solo	13/07/1942		Mismatch
4	Rodgers	22/06/1981	PQ5 7ST	Correct to ID 4
5	Rodgers	22/06/1981	PQ5 7ST	Correct to ID 4
6	Picard	31/01/1950	AB1 2CD	Mismatch
7	Picard	31/01/1950	AB1 2CD	Mismatch
8	Picard	31/01/1950		Mismatch
9	Picard	31/01/1950		Mismatch
10	Jones	17/09/1970	YU5 0RT	Mismatch
11	Jones	17/09/1970	FD7 1SA	Mismatch
12	David	24/07/1990		Correct to ID 12
13	David	24/07/1990		Correct to ID 12

I want my code to look through the surnames and DOB iteratively to find a matching group. Then compare the postcodes in that group to determine whether there is a match or not. If there is a match, the correct ID is the first one in the group. If not, I would specify there is a mismatch.

Here is what I have written so far. It works on the majority but there are cases when it doesn't output the correct comment.

Sub ProcessNames()

    Dim wb As Workbook, ws As Worksheet
    Dim dict As Object, sKey As String
    Dim iLastRow As Long, iRow As Long
    Dim Count As Long

    Set dict = CreateObject("Scripting.Dictionary")

    Set wb = ThisWorkbook
    Set ws = wb.Sheets("Sheet1")
    iLastRow = ws.Cells(Rows.Count, 1).End(xlUp).Row

    ' this count was just some improvisation to make the code work
    Count = 0

    For iRow = 2 To iLastRow
            ' create key using LastName and DOB
            sKey = UCase(ws.Cells(iRow, "B")) & Format(Cells(iRow, "C"), "DDMMYYYY")
        
            If dict.exists(sKey) Then
                If ws.Cells(iRow, "D") = ws.Cells(dict(sKey), "D") Or ws.Cells(iRow, "D") = ws.Cells(dict(sKey), "D") = "" Then
                    Count = Count + 1
                    dict(sKey) = (iRow - Count)
                End If
            Else
                dict(sKey) = iRow
                Count = 0
            End If

    Next

    ' update correct IDs in Comment
    For iRow = 2 To iLastRow
    
        sKey = UCase(ws.Cells(iRow, "B")) & Format(Cells(iRow, "C"), "DDMMYYYY")
        
        If ws.Cells(iRow, "D") = ws.Cells(dict(sKey), "D") Or ws.Cells(iRow, "D") = ws.Cells(dict(sKey), "D") = "" Then
            ws.Cells(iRow, "E") = "Correct to ID " & ws.Cells(dict(sKey), "A")
        Else
            ws.Cells(iRow, "E") = "Mismatch"
        
        End If
   
        
    Next
    
    
    ' Ideally I wouldn't need this but it can't seem to make it work without it
    For iRow = 2 To iLastRow
    
        sKey = UCase(ws.Cells(iRow, "B")) & Format(Cells(iRow, "C"), "DDMMYYYY")
        
        If ws.Cells(iRow, "E") = "Mismatch" Then
            ws.Cells((iRow - 1), "E") = "Mismatch"
        End If
        
   
    Next
    
End Sub

There are some errors with this code, notably for groups where there are 2 of the same postcode, using Picard above as an example:

A	B	C	D	E
6	Picard	31/01/1950	AB1 2CD	Correct to ID 6
7	Picard	31/01/1950	AB1 2CD	Correct to ID 6
8	Picard	31/01/1950		Mismatch
9	Picard	31/01/1950		Mismatch

Whereas all the comments should be 'Mismatch'.

Also for groups where they should all be 'Mismatch' it sometimes says the first entry as 'Correct to ...' and the rest 'Mismatch' when in fact the whole group should be 'Mismatch'. This led me to write the code at the bottom that would make the cell above 'Mismatch' but I want it to work correctly without this.

I have been trying to fiddle around with it for hours but to no avail.

Thank you for your assistance. I hope this is somewhat clear!

 

[alansidman]

Here is a link on how to do this with a parameter query in Power Query/Get and Transform.

 

[Fluff]

Hi & welcome to MrExcel.
How about

Sub Hammy()
   Dim Ary As Variant, Nary As Variant
   Dim i As Long
   Dim Txt As String, Tmp As String
   
   Ary = Range("A2:D" & Range("A" & Rows.Count).End(xlUp).row).Value2
   ReDim Nary(1 To UBound(Ary), 1 To 1)
   With CreateObject("scripting.dictionary")
      For i = 1 To UBound(Ary)
         Txt = Ary(i, 2) & Format(Ary(i, 3), "ddmmyyyy")
         If Not .Exists(Txt) Then
            .Add Txt, Array(i, "O")
         ElseIf .Item(Txt)(1) = "O" Then
            If Ary(i, 4) <> Ary(.Item(Txt)(0), 4) Then .Item(Txt) = Array(.Item(Txt)(0), "N")
         End If
      Next i
      For i = 1 To UBound(Ary)
         Txt = Ary(i, 2) & Format(Ary(i, 3), "ddmmyyyy")
         If .Item(Txt)(1) = "O" Then
            Nary(i, 1) = "Correct to ID " & Ary(.Item(Txt)(0), 1)
         Else
            Nary(i, 1) = "Mismatch"
         End If
      Next i
   End With
   Range("E2").Resize(UBound(Nary)).Value = Nary
End Sub

 

[Hammy123]

Thank you so much @Fluff! That has resolved my issue perfectly, I'm in awe of your coding prowess - it's so sleek and elegant!

I've had trouble trying to apply this to my actual spreadsheet though as the columns and range are different:

A	B	C	D	E	F	G	H
...	ID	...	Last Name	DOB	...	Postcode	Comment

I've amended the code to account for the range as follows:

Ary = Range("B49096:G61043")

Range("H49096").Resize(UBound(Nary)).Value = Nary

But I've been unable to make the rest of it work correctly...

 

[Fluff]

How about

Sub Hammy()
   Dim Ary As Variant, Nary As Variant
   Dim i As Long
   Dim Txt As String, Tmp As String
   
   Ary = Range("B49096:G61043").Value2
   ReDim Nary(1 To UBound(Ary), 1 To 1)
   With CreateObject("scripting.dictionary")
      For i = 1 To UBound(Ary)
         Txt = Ary(i, 3) & Format(Ary(i, 4), "ddmmyyyy")
         If Not .Exists(Txt) Then
            .Add Txt, Array(i, "O")
         ElseIf .Item(Txt)(1) = "O" Then
            If Ary(i, 6) <> Ary(.Item(Txt)(0), 6) Then .Item(Txt) = Array(.Item(Txt)(0), "N")
         End If
      Next i
      For i = 1 To UBound(Ary)
         Txt = Ary(i, 3) & Format(Ary(i, 4), "ddmmyyyy")
         If .Item(Txt)(1) = "O" Then
            Nary(i, 1) = "Correct to ID " & Ary(.Item(Txt)(0), 1)
         Else
            Nary(i, 1) = "Mismatch"
         End If
      Next i
   End With
   Range("H49096").Resize(UBound(Nary)).Value = Nary
End Sub

 

[Hammy123]

Thank you for the swift reply, that's done the trick!

I tried exactly that except I missed the .Value2 from Ary = Range("B49096:G61043").Value2 ??‍

I really appreciate your support @Fluff, you have a great day and week

 

[Fluff]

You're welcome & thanks for the feedback.