Option Explicit
Sub TEST()
Dim Y, xR As Range, Ra As Range, xD
Set Y = CreateObject("Scripting.Dictionary")
Set xR = ActiveSheet.UsedRange
For Each Ra In xR.SpecialCells(2)
On Error Resume Next
If IsDate(CDate(Ra)) = False Then GoTo i01
On Error GoTo 0
xD = CDate(Ra) & ""
If Not Y.Exists(xD) Then
Set Y(xD) = Ra
Else
Set Y(xD) = Union(Y(xD), Ra)
End If
i01:
Next
Application.Goto Y(Date & ""): MsgBox "今天"
Application.Goto Y(Date + 1 & ""): MsgBox "明天"
Application.Goto Y(Date + 2 & ""): MsgBox "後天"
Set Y = Nothing: Set xR = Nothing: Set Ra = Nothing
End Sub作者: coafort 時間: 2023-4-7 14:12
