excel - 排序日期并显示最近的 VBA

Question

我有以下列表，我想对日期进行排序并显示最近的日期并将它们存储在 21 和 22 范围内，如下所示：

我已经成功编写了这段代码来帮助进行排序并显示最近的日期并将它们存储在 21 范围内，现在我是堆栈，我不知道如何显示与每个最近日期关联的结束日期。

 Loop Until Not ech

      ' conversion of numbers into text for dico and  listbox)
      ' and the false dates (written in text) to real dates
      On Error GoTo PasDate
      For i = 2 To UBound(t)
         t(i, 1) = CStr(t(i, 1))
         If TypeName(t(i, 2)) = "String" Then t(i, 2) = 1 * DateSerial(Right(t(i, 2), 4), Mid(t(i, 2), 4, 2), Left(t(i, 2), 2))
      Next i
      On Error Resume Next

      'Fill dico
      Set dico = CreateObject("scripting.dictionary")
      dico.CompareMode = TextCompare
      For i = 2 To UBound(t)
         If t(i, 1) <> "" Then
            If Not dico.Exists(t(i, 1)) Then
               dico.Add t(i, 1), t(i, 2)
            Else
               If t(i, 2) > dico(t(i, 1)) Then dico(t(i, 1)) = t(i, 2)
            End If
         End If
      Next i

   'Transfert dico to the table  r for the list
   ReDim r(1 To dico.Count, 1 To 2): i = 0
   For Each x In dico.Keys: i = i + 1: r(i, 1) = x: r(i, 2) = dico(x): Next

   'fill ranges 20 and 21 
   .Range("b20:b21").Resize(, Columns.Count - 1).Clear

   .Range("b20").Resize(1, UBound(r)).HorizontalAlignment = xlCenter
   .Range("b21").Resize(1, UBound(r)).NumberFormat = "dd/mm/yyyy"
   .Range("b20").Resize(2, UBound(r)).Borders.LineStyle = xlContinuous
   .Range("b20:b21").Resize(2, UBound(r)) = Application.Transpose(r)

   End With

   'poplate the listbox
    For i = 1 To UBound(r): r(i, 1) = Format(r(i, 2), "dd/mm/yyyy"): Next

   'For i = 1 To UBound(r): r(i, 1) = Format(r(i, 1), "000"): r(i, 2) = Format(r(i, 2), "dd/mm/yyyy"): Next

   With ListBox1
      .ColumnCount = 2
      .ColumnHeads = False
      .ColumnWidths = .Width * 0.7        '& ";" & .Width * (1 - 0.6 + 0.1)
      .List = r
   End With
   Exit Sub

'
PasDate:
Exit Sub
   End
End Sub

标签： excelvba