到达日期范围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 

的各种测试