SlavyanZbl, код и так перебирал со второй строки и до последней, эти изменения без толку, отключите On Error Resume Next и увидите.
Ну а если нашли что пропускает - расскажите что, мне искать недосуг.
Вижу только что исходные данные не отсортированы. Т.е. не совпадает с тем, что показывали как пример. Я говорил про сортировку.
Но если говорите что на стыке дат поездок не будет - то и ладно, может так оставаться.
P.S. Кстати наверное лучше убрать обработку ошибок - из-за этого могут проскочить косячки, вижу что Вы вытянули на 3 строки больше.
Хотя признаю, нужно дорабатывать, тянет вероятно лишнее - например вот эти строки:
74 30.04.2025 13:36:35 000002490
74 30.04.2025 13:45:00 000002490
74 30.04.2025 13:45:00 000002490
74 30.04.2025 13:52:59 000002490
Тут разница в 10 минут есть от 45 вниз и вверх, поэтому их две и вытягивает, а по сути не должно.
Нужно чуть скорректировать код - просматривать не 7 строк, а только 4, ну и вывод подправить...
Вот чуть доработал, проверьте.
Скрытый текст |
---|
Код |
---|
Option Explicit
Sub tt()
Dim a, i&, ii&, x&, r$, k$, t As Double
Dim col As New Collection, el
a = [a1].CurrentRegion.Value
For i = 2 To UBound(a) - 3
r = a(i, 1)
k = a(i, 4)
t = a(i, 2) + a(i, 3)
x = 0
For ii = 0 To 3
If r = a(i + ii, 1) Then
If k = a(i + ii, 4) Then
If Abs(t - (--a(i + ii, 2) + --a(i + ii, 3))) <= 1 / 24 / 6 Then
x = x + 1
'Debug.Print k & " - " & x & "-" & CDate(Abs(t - (a(i + ii, 2) + a(i + ii, 3))))
End If
End If
End If
Next
If x > 3 Then
On Error Resume Next ' так медленнее чем поставить в начало, но подстраховка от других ошибок
col.Add i, CStr(i)
col.Add i + 1, CStr(i + 1)
col.Add i + 2, CStr(i + 2)
col.Add i + 3, CStr(i + 3)
On Error GoTo 0
End If
Next
i = 1
With Sheets(2)
.Cells.ClearContents
.Cells(i, 1) = "Номер маршрута"
.Cells(i, 2) = "Дата поездки"
.Cells(i, 3) = "Время поездки"
.Cells(i, 4) = "Номер карты"
For Each el In col
i = i + 1
.Cells(i, 1).Resize(, 4).Value = Sheets(1).Cells(el, 1).Resize(, 4).Value
Next
End With
MsgBox "Готово", vbInformation
End Sub
|
|