到达date范围VBA
首先，我只是VBA的初学者，我陷入了困境，找不到一条可能的出路。 准确地说，根据我的要求，下面附上的是我目前的数据的快照。 在“date范围”列中，我需要基于每张发票中可用date的date范围。 如果连续性在date中断，我将需要样本数据中显示的以逗号分隔的date。 以下是我的代码只到达date，不能形成date范围。 希望我能find自己的出路，并会从中获得新的东西:-)谢谢！ 
] 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
各种testing的屏幕截图 