確定日期差距給定日期列表的長度

Question

我試圖編寫一個腳本來搜索日期列表，並確定日期間隔有多長。我是新來的VBA，這可能是完全錯誤的，但是引用幾個網站後，這裏是我想出了：

Sub IdentifyGaps() 

Dim startdate As Date 'first date in column 
Dim enddate As Date 'last date in column 
Dim ust As Date 'first date of unemployment 
Dim i As Long 
ust = ActiveCell.Offset(1, 0).Value 

With Sheet6 
    startdate = [A1] 
    enddate = .Cells(.Rows.Count, "A").End(xlUp).Value 

    For i = startdate To enddate 
     If ust <> DateAdd("d", 1, i) Then 
      Sheet6.[C1].Value = DateDiff("d", i, ust) 
     End If 
    Next i 
End With 

End Sub 

我沒有收到一個錯誤，但宏無法正常工作。現在，它應該返回15時返回-43074.任何幫助將非常感謝！

下面是數據的屏幕截圖，其中應該顯示唯一的日期差距。

Answer 1

Sub IdentifyGaps() 

Dim ws As Worksheet 
Dim Date1 As Long, Date2 As Long, Gap As Long, lRow As Long 

Set ws = Sheet6 
lRow = ws.Range("C" & Rows.Count).End(xlUp).Row 

For x = 1 To ws.Range("A" & Rows.Count).End(xlUp).Row 
    Date1 = ws.Cells(x, 1).Value 
    Date2 = ws.Cells(x + 1, 1).Value 
    Gap = DateDiff("d", Date1, Date2) 
    If Gap > 1 Then 
     ws.Range("C" & lRow).Value = Gap 
     lRow = lRow + 1 
    End If 
Next x 

Answer 2

看着我的日曆，我相信你預期的結果實際上應該是17，不是15，此代碼將返回間隙值作爲Long值與你可以做任何你想要的。

'Reads a column of dates and returns the length of the first gap found 
Function IdentifyGaps() As Long 
    Dim StartDate As Date 
    Dim EndDate As Date 

    'This Variable is not needed for this solution, it is instead replaced by Gap 
    'Dim ust As Date 
    Dim Gap As Long 

    'Read cell values into an array for more efficient operation 
    Dim ReadArray() As Variant 
    ReadArray = Sheet6.Range("A1").CurrentRegion 

    Dim LastRow As Long 
    LastRow = UBound(ReadArray, 1) 

    StartDate = ReadArray(1, 1) 
    EndDate = ReadArray(LastRow, 1) 

    'ThisDate and PreviousDate are declared explicitly to highlight program flow 
    Dim Row As Long 
    Dim ThisDate As Date 
    Dim PreviousDate As Date 
    For Row = 2 To UBound(ReadArray, 1) 
     ThisDate = ReadArray(Row, 1) 
     PreviousDate = ReadArray(Row - 1, 1) 
     Gap = ThisDate - PreviousDate 
     If Gap > 1 Then Exit For 
     Gap = 0 
    Next Row 

    IdentifyGaps = Gap 
End Function 
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' 
Sub ProveIt() 
    Debug.Print IdentifyGaps 
End Sub