到达日期范围VBA

Question

首先，我只是VBA的初学者而且我被困在中间，无法找到可能的出路。为了确切地说明我的要求，下面附上的是我目前所拥有的数据的快照。在日期范围列中，我需要一个基于每张发票中可用日期的日期范围。如果连续性在日期中断，我将需要用逗号分隔的日期，这些日期显示在样本数据中。下面是我的代码段，它只到达日期而不能形成日期范围。希望我能找到自己的出路并从中获得新的东西:-)谢谢！] 1

Sub DD()

With Application
.ScreenUpdating = False
.DisplayAlerts = False
.EnableCancelKey = False
.EnableEvents = False
End With

Sheets("Claim Lines").Select

ActiveWorkbook.Worksheets("Claim Lines").Sort.SortFields.Clear

ActiveWorkbook.Worksheets("Claim Lines").Sort.SortFields.Add Key:=Range("B1"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortTextAsNumbers
ActiveWorkbook.Worksheets("Claim Lines").Sort.SortFields.Add Key:=Range("D1"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortTextAsNumbers
With ActiveWorkbook.Worksheets("Claim Lines").Sort
    .SetRange ActiveSheet.UsedRange
    .Header = xlYes
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
End With

Range("B2").Select

Do

    If ActiveCell.Value = ActiveCell.Offset(1, 0).Value Then
        StrtRow = 2
        tmperow = ActiveSheet.UsedRange.Rows.Count
        For j = 0 To Application.WorksheetFunction.CountIf(Range("B" & StrtRow & ":B" & tmperow), ActiveCell.Value) - 1
            If j = 0 Then
                DOS = CDate(Cells(ActiveCell.Offset(0, 2).Row + j, "D").Value)
            ElseIf j = Application.WorksheetFunction.CountIf(Range("B" & StrtRow & ":B" & tmperow), ActiveCell.Value) - 1 Then
                ElseIf DOS = DOS Then
                DOS = CDate(Cells(ActiveCell.Offset(0, 2).Row + j, "D").Value)
            ElseIf j = Application.WorksheetFunction.CountIf(Range("B" & StrtRow & ":B" & tmperow), ActiveCell.Value) - 1 Then
            ElseIf DOS = DOS Then
                DOS = DOS & " & " & CDate(Cells(ActiveCell.Offset(0, 2).Row + j, "D").Value)
            Else
                DOS = DOS & ", " & CDate(Cells(ActiveCell.Row + j, "D").Value)
            End If
        Next
        Range("N" & ActiveCell.Row).Value = DOS & " to " & DOS
        DOS = ""
        Else
        Range("N" & ActiveCell.Row).Value = Range("D" & ActiveCell.Row).Value
        End If

        ActiveCell.Offset(1, 0).Select

Loop Until IsEmpty(ActiveCell.Value)


End Sub

Answer 1

我很快写了这个。我相信可以有更好的方法来实现这一目标，但我只能花费这么多时间才能解决问题：）

Sub Sample()
    Dim ws As Worksheet
    Dim dString As String, ss As String
    Dim lRow As Long, i As Long
    Dim sRow As Long, eRow As Long
    Dim sDate As Date, eDate As Date

    '~~> This is your worksheet which has data
    Set ws = ThisWorkbook.Worksheets("Claim Lines")

    '~~> Setting start row and end row for Col C
    sRow = 2: eRow = 2

    With ws
        '~~> Sort Col A and B on Col A first and then on Col B
        .Columns("A:B").Sort Key1:=.Range("A1"), Key2:=.Range("B1"), _
        Order1:=xlAscending, Header:=xlYes, OrderCustom:=1, MatchCase:=False, _
        Orientation:=xlTopToBottom, DataOption1:=xlSortNormal

        '~~> Find Last Row of Col A
        lRow = .Range("A" & .Rows.Count).End(xlUp).Row

        '~~> Set the Initial Start Date and End Date
        sDate = .Range("B2").Value: eDate = .Range("B2").Value

        '~~> Loop through the data
        For i = 2 To lRow
            '~~> Check if the value of the current cell in Col A
            '~~> is the same as the value in the next cell
            If .Range("A" & i) = .Range("A" & i + 1) Then
                '~~> Compare date values in Col B to check if they are in sequence
                If .Range("B" & i + 1) - .Range("B" & i) = 1 Then
                    '~~> If yes then set it as new End Date
                    eDate = .Range("B" & i + 1)
                Else
                    '~~> Get the string to be written in Col C
                    dString = GetDString(dString, sDate, eDate, .Range("B" & i))
                    '~~> Set New Start Date
                    sDate = .Range("B" & i + 1)
                End If
            Else
                eRow = i
                dString = GetDString(dString, sDate, eDate, .Range("B" & i))
                .Range("C" & sRow & ":C" & eRow).Value = dString
                dString = "": sRow = eRow + 1
                sDate = .Range("B" & i + 1).Value
                eDate = .Range("B" & i + 1).Value
            End If
        Next i
    End With
End Sub

'~~> Function to get the string to be written in Col C
Private Function GetDString(s As String, StartDate As Date, _
endDate As Date, CurCell As Range) As String
    If s = "" Then
        If endDate = CurCell.Value Then
            If StartDate = endDate Then
                s = StartDate
            Else
                s = StartDate & "-" & endDate
            End If
        Else
            s = (StartDate & "-" & endDate) & "," & CurCell.Value
        End If
    Else
        If endDate = CurCell.Value Then
            s = s & "," & StartDate & "-" & endDate
        Else
            s = s & "," & CurCell.Value
        End If
    End If
    GetDString = s
End Function

各种测试的ScreenShot