Как сделать цикл For с оператором If более эффективным при переборе строк в VBa?

Question

У меня есть цикл For, вложенный в другой цикл For, который выполняет итерацию для каждой строки в электронной таблице.

Вложенный ниже цикл for проверяет текущую строку, а затем проходит по каждой строке в электронной таблице, чтобы увидеть,соответствует критериям оператора If.Если это так, он изменяет bool на True и выходит из вложенного цикла.

Этот метод занимает слишком много времени.Электронная таблица состоит из 1000 строк и 27 столбцов, и на маленьком ПК, который я использую, будет работать вечно.

Код:

    Sub Check_Errors()
    Dim x As Integer
    Dim lastRow As Long
    Dim duplicateData As Boolean

    Set Data = ThisWorkbook.Sheets("Data") 'Worksheet with Raw data
    Set Errors = ThisWorkbook.Sheets("Errors") 'Where any flagged rows are copied to.

    x = 2
    lastRow = Data.Cells(Data.Rows.Count, "A").End(xlUp).Row
    duplicateData = False

'Copies the headings from Data worksheet to Error worksheet
    For j = 1 To 26
        Errors.Cells(1, j).Value = Data.Cells(1, j).Value
    Next j

    Errors.Cells(1, 27).Value = "Error Type"

    For i = 2 To lastRow

        wrongSpeciality = False



            For j = 2 To 300
                If ((Data.Cells(i, 19) < Data.Cells(j, 19) + (Data.Cells(j, 20) / 1440) + (Data.Cells(j, 21) / 1440) _
                And Data.Cells(i, 19) >= Data.Cells(j, 19)) _
                Or _
                (Data.Cells(i, 19) + (Data.Cells(i, 20) / 1440) + (Data.Cells(i, 21) / 1440) <= Data.Cells(j, 19) + (Data.Cells(j, 20) / 1440) + (Data.Cells(j, 21) / 1440) _
                And Data.Cells(i, 19) + (Data.Cells(i, 20) / 1440) + (Data.Cells(i, 21) / 1440) > Data.Cells(j, 19))) _
         _
                And Data.Cells(i, 18) = Data.Cells(j, 18) _
                And Data.Cells(i, 22) = Data.Cells(j, 22) _
                And Not i = j Then

                    duplicateData = True
                    Exit For

                End If
            Next j

'If true then copy flagged row to Error worksheet and add additional column with reason row was flagged.   
        If duplicateData Then

            For j = 1 To 26
                Errors.Cells(x, j).Value = Data.Cells(i, j).Value
            Next j
            Errors.Cells(x, 27).Value = "Time overlapping"
            x = x + 1
        End If

    Next i

Данные

ClinicalTime и AdminTime указаны в минутах и ​​должны быть разделены на 1440 перед добавлением в Time, чтобы получить правильное время окончания.

Джеймс видит кого-то в 13:00 12 января и заканчивает в 13:30.Но это также показывает, что он увидел кого-то в 13:25, что было невозможно, поскольку он был с кем-то в течение этого времени.

Приведенный выше код изменит duplicateData на True для обеих этих строк, но приметочень много времени для этого в тысячах таких случаев.

Columns 18        19     20             21            22
        Date      Time   ClinicalTime   AdminTime     Clinician
        12/01/18  13:00  20             10            James
        12/01/18  13:25  10             20            James
        12/01/18  14:30  40              0            James
        14/01/18  10:00  20             20            Samantha 

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

Answer 1

Представьте себе следующие данные:

Сортировать по ОБА:

• Колонка V (клиницист) A…Z
• И столбец W (START) низкий… высокий

Я добавил 3 столбца W, X и Y (вы можете использовать другие).Формулы:

• Столбец W: =R:R+S:S (складывает дату и время начала)
• Столбец X: =R:R+S:S+T:T/1440+U:U/1440 (вычисляет дату / время окончания)
• Y2 (и скопировать вниз): =IF(AND(V2=V1,W2<X1),"Overlapping","-")

Затем отфильтруйте по столбцу Y (перекрытие), и у вас есть ваши данные.

Как работает формула?
Формула проверяет для каждого ряда, является ли клиницист тем же, что и в предыдущем ряду (в противном случае это первый ряд этого клинициста, который никогда не может совпадать).Затем он проверяет, является ли START до КОНЕЦом строки ранее.Если это так, то это перекрытие, в противном случае - нет.

Обратите внимание, что этот метод работает только с правильно отсортированными данными.

---

Если использование формул не соответствует вашим потребностям, тогда идея этого метода можеттакже будет использоваться в VBA.Это должно быть на намного быстрее, потому что для тестирования потребуется только минимальный объем данных, и вам нужно пройти по всем строкам только один раз.

Option Explicit

Public Sub CheckForOverlappings()
    Dim wsData As Worksheet
    Set wsData = ThisWorkbook.Worksheets("Data")

    Dim wsErrors As Worksheet
    Set wsErrors = ThisWorkbook.Worksheets("Errors")

    Dim LastDataRow As Long
    LastDataRow = wsData.Cells(wsData.Rows.Count, "A").End(xlUp).Row

    Dim LastErrorRow As Long
    LastErrorRow = 2

    'sort data by …
    With wsData.Sort
        .SortFields.Clear
        '… field Clinician
        .SortFields.Add2 Key:=Range("V2"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        '… field Date
        .SortFields.Add2 Key:=Range("R2"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        '… field Time
        .SortFields.Add2 Key:=Range("S2"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal

        .SetRange Range("1:" & LastDataRow)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With


    'write headers for error sheet
    wsErrors.Cells(1, 1).Resize(ColumnSize:=26).Value = wsData.Cells(1, 1).Resize(ColumnSize:=26).Value
    wsErrors.Cells(1, 27).Value = "Error Type"

    'read relevant data into array
    Dim arrData As Variant
    arrData = wsData.Range(wsData.Cells(1, 18), wsData.Cells(LastDataRow, 22))

    'initialize start/enddate with first data row (= row 2)
    Dim StartDate As Date
    StartDate = arrData(2, 1) + arrData(2, 2)
    Dim EndDate As Date
    EndDate = StartDate + arrData(2, 3) / 1440 + arrData(2, 4) / 1440

    Dim iRow As Long
    For iRow = 3 To UBound(arrData, 1) 'loop from data row 2 (= row 3) we used data row 1 in initialization already
        'determine start date of current row
        StartDate = arrData(iRow, 1) + arrData(iRow, 2)

        If arrData(iRow, 1) = arrData(iRow - 1, 1) And StartDate < EndDate Then 'check same cinician and overlapping
            'copy column 1 … 26 to error sheet
            wsErrors.Cells(LastErrorRow, 1).Resize(ColumnSize:=26).Value = wsData.Cells(iRow, 1).Resize(ColumnSize:=26).Value

            LastErrorRow = LastErrorRow + 1
        End If

        'remember end date of current row (for comparison with next row)
        EndDate = StartDate + arrData(iRow, 3) / 1440 + arrData(iRow, 4) / 1440
    Next iRow
End Sub