比较循环中的日期

Question

我有一个循环，检查整个日期列。 我希望那个循环检查是否与前一个单元格（-1）仍然是同一天。数据组织如下：

    ID     DATE       TIME     PRICE       QUANTITY    NBE

我已尝试将以下代码作为我的循环的参数，但它不起作用...日期位于B列，格式如下：dd：mm：yyyy

这就是我的新代码的样子

Sub Macro1()

Dim lngFirstRow As Long, lngLastRow As Long, cRow As Long, lngNextDestRow As Long
Dim jbs As Date
Dim shSrc As Worksheet, shDest As Worksheet

Set shSrc = ActiveWorkbook.Sheets("2008P1")
Set shDest = ActiveWorkbook.Sheets("Sheeet2")


With shSrc

    lngFirstRow = 2
    lngLastRow = .Cells.Find(What:="*", after:=.Cells.Cells(1), LookAt:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False).Row
    lngNextDestRow = 2



    For cRow = lngFirstRow To lngLastRow Step 1
        jbs = .Cells(cRow, 2)

        If jbs <> .Cells(cRow - 1, 2).Value Then
            .Rows(cRow).EntireRow.Copy Destination:=shDest.Range("A" & lngNextDestRow)
            .Rows(cRow + 1).EntireRow.Copy Destination:=shDest.Range("A" & lngNextDestRow + 1)
            lngNextDestRow = lngNextDestRow + 2

        End If
    Next cRow
 End With
End Sub

感谢你的回复Branislav我编辑了这个;）它似乎运作良好。

Answer 1

以下是适用于我的代码：

Sub test()
Dim dTest As Date
Dim j As Long
Dim rCount As Long

j = 1

For i = 1 To Cells(Rows.Count, 1).End(xlUp).Row
    rCount = 0
    j = i
    dTest = Cells(i, 1).Value

    While dTest = Cells(j, 1).Value
        'Here should be the code which tells what to do
        'when the date is the same
        j = j + 1
        rCount = rCount + 1
    Wend

    i = i + rCount - 1
Next i
End Sub

当我有这样的日期时：

当你添加一些msgbox时，它会返回这个：

我希望我能帮到你

问候 Amnney

Answer 2

此代码将提取两行完全相同的日期，然后移至其他日期。 如果日期仅在数据库中，则无效。。

Sub FindSameDatesCopy2Rows()
'Check if the 2 subsequent dates are the same and extract the whole rows to other sheet
'Then move to other date and again check and extract. Repeat.

    Dim lngNextDestRow As Long
    Dim shDest As Worksheet
    Dim bolExitLoop As Boolean
    Dim jbs As Variant
    Dim cRow As Long
    Dim cRow2 As Long
    Dim rngNextDay As Range
    Dim lngFirstRow  As Long
    Dim lngLastRow  As Long

    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlManual

    lngNextDestRow = 2 'change to your situation
    lngFirstRow = 1 'change to your situation
    lngLastRow = 19 'change to your situation
    Set shDest = Worksheets(3) 'change to your situation

    With Worksheets(2) 'change to your situation
        For cRow = lngFirstRow To lngLastRow Step 1
            If bolExitLoop And cRow = lngFirstRow Then Exit For 'need to set this to exit infinite loop, because .Find will wrap again and again
            jbs = .Cells(cRow, 2)
            If jbs = .Cells(cRow + 1, 2) Then
                .Rows(cRow & ":" & cRow + 1).Copy shDest.Rows(lngNextDestRow)
                lngNextDestRow = lngNextDestRow + 2
                For cRow2 = cRow To lngLastRow
                    'find the next day, any day
                    Set rngNextDay = .Range("B:B").Find("*", after:=.Cells(cRow2, 2))

                    'compare if the day is different than that we already done
                    If rngNextDay <> jbs Then
                        'set the row for next loop
                        cRow = rngNextDay.Row - 1
                        'need to set this to exit infinite loop, because .Find will wrap again and again
                        bolExitLoop = True
                        Exit For
                    End If
                Next cRow2
            End If

        Next cRow
    End With

    Application.ScreenUpdating = True
    Application.Calculation = xlAutomatic
    Application.EnableEvents = True

End Sub