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

Hammy123

New Member
Joined
Jun 28, 2020
Messages
3
Office Version
  1. 2019
Platform
  1. Windows
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:

ABCDE
IDLast NameDOBPostcodeComment
1Solo13/07/1942SW11 5WS Mismatch
2Solo13/07/1942Mismatch
3Solo13/07/1942Mismatch
4Rodgers22/06/1981PQ5 7STCorrect to ID 4
5Rodgers22/06/1981PQ5 7STCorrect to ID 4
6Picard31/01/1950AB1 2CDMismatch
7Picard31/01/1950AB1 2CDMismatch
8Picard31/01/1950Mismatch
9Picard31/01/1950Mismatch
10Jones17/09/1970YU5 0RTMismatch
11Jones17/09/1970FD7 1SAMismatch
12David24/07/1990Correct to ID 12
13David24/07/1990Correct 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.

VBA Code:
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:


ABCDE
6Picard31/01/1950AB1 2CDCorrect to ID 6
7Picard31/01/1950AB1 2CDCorrect to ID 6
8Picard31/01/1950Mismatch
9Picard31/01/1950Mismatch

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!
 

Excel Facts

Square and cube roots
The =SQRT(25) is a square root. For a cube root, use =125^(1/3). For a fourth root, use =625^(1/4).
Here is a link on how to do this with a parameter query in Power Query/Get and Transform.

 
Upvote 0
Hi & welcome to MrExcel.
How about
VBA Code:
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
 
Upvote 0
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:

ABCDEFGH
...ID...Last NameDOB...PostcodeComment

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

VBA Code:
Ary = Range("B49096:G61043")

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

But I've been unable to make the rest of it work correctly...
 
Upvote 0
How about
VBA Code:
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
 
Upvote 0
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 :)
 
Upvote 0
You're welcome & thanks for the feedback.
 
Upvote 0

Forum statistics

Threads
1,223,214
Messages
6,170,772
Members
452,353
Latest member
strainu

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