Диапазоны дат прибытия VBA

Прежде всего, я просто новичок в 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 

Я быстро написал это. Я уверен, что для этого могут быть лучшие способы, но я мог потратить столько времени, прежде чем я ударил мешок 🙂

 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 различных тестов введите описание изображения здесь

Interesting Posts
Давайте будем гением компьютера.