Ankommen Datum Bereiche VBA

Question

Zunächst einmal bin ich nur ein Anfänger in VBA und ich bin in der Mitte stecken geblieben und konnte keinen Ausweg finden. Um genau zu sein auf meine Anforderung, Anbei unten ist der Snapshot der Daten, die ich derzeit habe. In der Spalte Datumsbereich würde ich einen Datumsbereich benötigen, der auf den in den einzelnen Rechnungen verfügbaren Daten basiert. Wenn eine Kontinuität in den Daten bricht, würde ich die durch Komma getrennten Daten benötigen, die in den Beispieldaten gezeigt werden. Unten ist mein Codeabschnitt, der nur die Daten erreicht und keinen Datumsbereich bilden kann. Hoffe, ich kann meinen Ausweg finden und würde etwas Neues daraus gewinnen :-) Danke! ] 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

ich dies schnell geschrieben. Ich bin sicher, es kann bessere Möglichkeiten, dies zu erreichen, aber ich konnte so viel Zeit nur ausgeben, bevor ich den Sack schlagen :)

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 verschiedener Tests