Сравнение дат и автоподастановка данных

Sub Tablica_dat()
    Dim i&, j&, LastRow&, A, vX, Dic As Object
    Set Dic = CreateObject("Scripting.Dictionary"): Dic.CompareMode = 1
    With Sheets("Sheet1")
        LastRow = .UsedRange.Rows.Count + .UsedRange.Row - 1
        A = .Range("A1:F" & LastRow).Value
    End With
    For j = 1 To 5 Step 2
        For i = 2 To LastRow
            A(i, j) = Trim(A(i, j))
            If A(i, j) <> "" Then
                If Dic.Exists(A(i, j)) Then
                    Dic(A(i, j)) = Dic(A(i, j)) & "|" & A(i, j + 1)
                Else
                    Dic(A(i, j)) = String(j \ 2, "|") & A(i, j + 1)
                End If
            End If
        Next i
    Next j
    i = 1
    With Sheets("Sheet2")
        For Each vX In Dic.Keys
            i = i + 1
            With .Range("A" & i)
                .Value = CDate(vX)
                A = Split(Dic(vX), "|")
                For j = 0 To UBound(A)
                    .Offset(0, j + 1) = A(j)
                Next j
            End With
        Next vX
        .[A1].CurrentRegion.Sort .Range("A1:D" & Dic.Count), , , , , , , True
    End With
    Set Dic = Nothing
End Sub