Сравнение дат в цикле

Question

У меня есть цикл, который идет и проверяет весь столбец. И я хочу, чтобы этот цикл проверял, или нет, это все тот же день, что и предыдущая ячейка (-1). Данные организованы следующим образом:

ID  DATE  TIME  PRICE  QUANTITY NBE 

я уже пробовал как с помощью следующего кода в качестве аргумента для моего цикла, но это не работает ... Даты в колонке B, и форматированием как последуйте за: дд: мм : гггг

Вот что мой новый код выглядит

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 

Благодаря вашему ответ Бранислава я редактировал, как это;) И, кажется, работают хорошо.

Answer 1

Этот код будет извлекать 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 

Answer 2

Вот код, который работает для меня:

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 

Когда у меня есть даты, как это:

возвращает это, когда вы добавляете несколько msgboxes:

Надеюсь, что я смогу л.д. помочь вам

поздравления Amnney