How to find inconsistencies in dates using VBA [closed]

Question

I have an Excel file containing thousands of rows. There are ID, Planned End Date, and End Date columns.

All IDs need to have at least one same Planned End Date and End Date (equal C and D columns). If an ID doesn't satisfy this criterion, write it in another cell.

My desired answer is something like this (the answer is on the right side):

I'm not sure whether VBA Dictionary can handle this problem.
How can I do this using VBA?

Answer 1

The layout makes this a bit more challenging (due to filtering/unfiltering) but it's doable :)

Process:

1. Get all the values in ID
2. Get all the unique values in ID and filter it based on unique values
3. For each value when we filter, check if criteria is met
4. If criteria is not met, then copy the ID and Department

Code:

Option Explicit

Sub Unique()

Dim lr As Long
Dim lc As Long
Dim ws As Worksheet
Dim ws_new As Worksheet

Dim lr_add As Long
Dim clRow As Long

Application.ScreenUpdating = False

Set ws = ActiveWorkbook.Worksheets("Sheet1") 'Set sheet


lc = 4 ' Set table column
lr = ws.Cells(ws.Rows.Count, lc).End(xlUp).Row 'Get last row

'##### Get all the uniqe "Data Values" #####
' You need to activate "Tools" -> "References" -> "Microsoft Scripting Runtime" to make dictionary work
Dim vData()
Dim vDataUniqe As Object
Dim vDataRow As Long

Set vDataUniqe = CreateObject("Scripting.Dictionary")
vData = Application.Transpose(ws.Range(ws.Cells(1, 1), ws.Cells(ws.Cells(Rows.Count, 1).End(xlUp).Row, 1))) 'Get all the ID values in column

For vDataRow = 2 To UBound(vData, 1) 'Start from row 2 (to skip header) and add unique values to the dictionary
    vDataUniqe(vData(vDataRow)) = 1 'Add value to dictionary
Next


'##### Loop through all the unique data values #####
Dim vDataVal As Variant
Dim vDataValue As String
Dim MyRangeFilter As Range
Dim FndMatch As Long


Set MyRangeFilter = ws.Range(ws.Cells(1, 1), ws.Cells(lr, lc)) 'Set filter range to filter
For Each vDataVal In vDataUniqe.Keys 'Filter through all the unique names in dictionary "vDataUniqe"
    vDataValue = vDataVal 'Convert to string value for autofilter as it can't handle numbers
    'Debug.Print "Data Value: " & vDataValue 'Print current unique Data Value
    
    'Filter the data based on "Unique value"
    With MyRangeFilter
        .AutoFilter Field:=1, Criteria1:=vDataValue, Operator:=xlFilterValues 'Filter on Destination Pincode"
    End With
    
    FndMatch = 0 'Set dummy "Find Match". If match criteria is met, this one change to 1
    
    '##### Check criteria in the filtered result #####
    Dim cl As Variant
    For Each cl In ws.Range(ws.Cells(1, 1), ws.Cells(lr, 1)).SpecialCells(xlCellTypeVisible)
        'Debug.Print cl
        If ws.Cells(cl.Row, "C").Value = ws.Cells(cl.Row, "D") Then 'If Planned End Date and End date is the same then
            FndMatch = 1 'Change dummy to 1
            Exit For 'Exit "For each cl..." if match is found
        End If
        clRow = cl.Row 'Store row number to copy
    Next cl
    
    '##### If criteria is not satisfied #####
    If FndMatch = 0 Then 'If dummy variable still is 0 then
        
        On Error Resume Next
            Sheet1.ShowAllData 'remove filter to be able to paste the data to the table
        On Error GoTo 0
        
        lr_add = ws.Cells(ws.Rows.Count, "H").End(xlUp).Row 'Get last row in table to paste values
        ws.Cells(lr_add + 1, "H").Value = ws.Cells(clRow, "A").Value 'Copy and Paste ID
        ws.Cells(lr_add + 1, "I").Value = ws.Cells(clRow, "B").Value 'Copy and Paste Department
    End If
    
Next vDataVal

On Error Resume Next
    Sheet1.ShowAllData 'remove filter
On Error GoTo 0

ws.AutoFilterMode = False 'remove autofilter
Application.ScreenUpdating = True

End Sub