Excel 如何使用VBA查找日期中的不一致

我有一个包含数千行的Excel文件。有ID、计划结束日期和结束日期列

所有ID都需要至少有一个相同的计划结束日期和结束日期（相等的C和D列）。如果ID至少没有一个相同的计划开始结束日期和结束日期，请将它们写入另一个单元格

我想要的答案是这样的（答案在右边）：

我不确定VBA字典是否能处理这个问题。

---

如何使用VBA实现这一点？

布局使这一点更具挑战性（由于过滤/取消过滤），但它是可行的：）

过程：

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

获取ID中的所有值

获取ID中的所有唯一值，并根据唯一值对其进行筛选

对于筛选时的每个值，检查是否满足条件

如果不符合标准，则复制ID和部门

代码：

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

---

您的Excel版本是否可以访问？我的Excel版本是2019。我没有听说过泄漏公式日期是2019/19/13，谢谢。它解决了我的问题。很高兴它有帮助：），很高兴编码！