VBA, чтобы пропустить последовательные события - PullRequest
Новая
       3

VBA, чтобы пропустить последовательные события

1 голос
/ 11 марта 2020

У меня есть таблица данных Excel со следующим содержимым:

1-я строка: заголовки таблицы

A2: даты события A50001

B2: номера B50001 (CRITERIA 1)

C2: номера C50001 (CRITERIA 2)

E2: целевые ячейки E50001 (FLAG 1)

D2: целевая дата D50001 1

G2: G50001 целевые ячейки (FLAG 2)

F2: F50001 целевая дата 2

примечание: A2: G50001 может содержать ячейки с ошибками или пробелами

Я хотел бы выполнить обычное задание например, когда значение критериев 2 было больше, чем значение критериев 1, а значение критериев 1 было больше, чем значение критериев 1 предыдущей строки, тогда добавьте «FLAG 1» в ячейку той же строки в столбце E, когда значение критериев 2 было меньше, чем равный значению критерия 1 и значение критерия 1 было меньше, чем равное значению критерия 1 предыдущей строки, затем добавьте «FLAG 2» в ячейку той же строки в столбце G

Здесь я написал MACRO для этого 

Sub add_flag_with_criteria_1_2()

Dim i As Integer
Dim Dt As Long 'this line added
Dim Cr1 As Long
Dim Cr2 As Long
Dim flag1 As Long
Dim flag2 As Long
Dim F1date As Long
Dim F2date As Long
Dim F1roof As Long
Dim F2roof As Long
Dim LR As Long 'this line added
Dim ws As Worksheet
Set ws = Worksheets("CRITERIA")

LR = Application.WorksheetFunction.CountA(ws.Range("A1:A50001")) 'this line added
Dt = Application.WorksheetFunction.Match("Date", ws.Range("1:1"), 0) 'this line added
Cr1 = Application.WorksheetFunction.Match("CRITERIA1", ws.Range("1:1"), 0)
Cr2 = Application.WorksheetFunction.Match("CRITERIA2", ws.Range("1:1"), 0)
flag1 = Application.WorksheetFunction.Match("flag1", ws.Range("1:1"), 0)
flag2 = Application.WorksheetFunction.Match("flag2", ws.Range("1:1"), 0)
F1date = Application.WorksheetFunction.Match("F1date", ws.Range("1:1"), 0)
F2date = Application.WorksheetFunction.Match("F2date", ws.Range("1:1"), 0) 

For i = 2 To LR
F1roof = Application.WorksheetFunction.Max(ws.Range(Cells(2, 4), Cells(i, 4))) 'this line added
F2roof = Application.WorksheetFunction.Max(ws.Range(Cells(2, 6), Cells(i, 6))) 'this line added
If Cells(i, Cr2) > Cells(i, Cr1) And Cells(i, Cr1) > Cells(i - 1, Cr1) And Not F2roof < F1roof Then Cells(i, F1date).Value = Cells(i, Dt).Value
If Cells(i, Cr2) > Cells(i, Cr1) And Cells(i, Cr1) > Cells(i - 1, Cr1) And Not F2roof < F1roof Then Cells(i, flag1).Value = "FLAG1"
If Cells(i, Cr2) <= Cells(i, Cr1) And Cells(i, Cr1) <= Cells(i - 1, Cr1) And Not F1roof < F2roof Then Cells(i, F2date).Value = Cells(i, Dt).Value
If Cells(i, Cr2) <= Cells(i, Cr1) And Cells(i, Cr1) <= Cells(i - 1, Cr1) And Not F1roof < F2roof Then Cells(i, flag2).Value = "FLAG2"
Next


End Sub

У меня есть 2 основных вопроса здесь.

* 10 27 *

мои данные с числами могут достигать только строки 3XXXX или чего-то еще, ячейки ниже последней строки с номерами могут быть оставлены как ошибки или пробелы. Должен ли я справиться с этим с помощью application.worksheetfunction.counta и заменить последнюю строку (50001) на переменную?

Я хотел бы сделать вхождение флага 1 и флага 2 альтернативным. Т.е., если флаг 1 появляется последовательно перед следующим флагом 2, второй флаг 1 не будет добавлен (как, если флаг 1 произошел в 3/3/2020 и 5/3/2020, в то время как флаг 2 произошел в 2/3/2020 и 8 / 3/2020, флаг 1 не будет добавлен к 3/3/2020). Какой код я должен добавить для этой логи c?

Спасибо.

1 Ответ

0 голосов
/ 12 марта 2020

Дайте это попробовать. Применено более описательные имена и перемещены объявления ближе к месту их использования. 

Option Explicit

Sub add_flag_with_criteria_1_2()

    Dim ws As Worksheet
    Set ws = Worksheets.[_Default]("CRITERIA")

    Dim dateColumn As Long
    dateColumn = GetColumnNumber(ws, "Date")

    Dim criteria1Column As Long
    criteria1Column = GetColumnNumber(ws, "CRITERIA1")

    Dim criteria2Column As Long
    criteria2Column = GetColumnNumber(ws, "CRITERIA2")

    Dim flag1Column As Long
    flag1Column = GetColumnNumber(ws, "flag1")

    Dim flag2Column As Long
    flag2Column = GetColumnNumber(ws, "flag2")

    Dim flag1DateColumn As Long
    flag1DateColumn = GetColumnNumber(ws, "F1date")

    Dim flag2DateColumn As Long
    flag2DateColumn = GetColumnNumber(ws, "F2date")

    Dim flag1DateRoof As Long
    Dim flag2DateRoof As Long

    Dim flagToApply As Long
    flagToApply = 0

    Dim rowIndex As Integer
    Dim lastRow As Long

    lastRow = Application.WorksheetFunction.CountA(ws.Range("A1:A50001"))

    For rowIndex = 2 To lastRow
        If Not IsBlankOrError(ws, rowIndex, criteria1Column, criteria2Column) Then
            flag1DateRoof = Application.WorksheetFunction.Max(ws.Range(Cells.Item(2, 4), Cells.Item(rowIndex, 4)))

            flag2DateRoof = Application.WorksheetFunction.Max(ws.Range(Cells.Item(2, 6), Cells.Item(rowIndex, 6)))

            If Not flag2DateRoof < flag1DateRoof And flagToApply <> 1 Then

                If ws.Cells.Item(rowIndex, criteria2Column).Value > ws.Cells.Item(rowIndex, criteria1Column).Value And Cells.Item(rowIndex, criteria1Column) > Cells.Item(rowIndex - 1, criteria1Column) Then

                    If flagToApply = 0 Then flagToApply = 1

                    ws.Cells.Item(rowIndex, flag1DateColumn).Value = ws.Cells.Item(rowIndex, dateColumn).Value
                    flagToApply = ApplyFlagValue(flagToApply, flag1Column, flag2Column, rowIndex)
                End If
            End If


            If Not flag1DateRoof < flag2DateRoof And flagToApply <> 2 Then
                If ws.Cells.Item(rowIndex, criteria2Column) <= ws.Cells.Item(rowIndex, criteria1Column) And ws.Cells.Item(rowIndex, criteria1Column) <= ws.Cells.Item(rowIndex - 1, criteria1Column) Then

                    If flagToApply = 0 Then flagToApply = 2

                    ws.Cells.Item(rowIndex, flag2DateColumn).Value = ws.Cells.Item(rowIndex, dateColumn).Value
                    flagToApply = ApplyFlagValue(flagToApply, flag1Column, flag2Column, rowIndex)
                End If
            End If
        End If
    Next

End Sub

Private Function IsBlankOrError(ws As Worksheet, ByVal rowIndex As Long, ByVal criteria1Column As Long, ByVal criteria2Column As Long) As Boolean
    IsBlankOrError = False
    If IsBlank(ws.Cells.Item(rowIndex, criteria1Column)) Or IsBlank(ws.Cells.Item(rowIndex, criteria2Column)) Then
        IsBlankOrError = True
    ElseIf IsError(ws.Cells.Item(rowIndex, criteria1Column)) Or IsError(ws.Cells.Item(rowIndex, criteria2Column)) Then
        IsBlankOrError = True
    End If
End Function

Private Function ApplyFlagValue(ByVal flagToApply As Long, ByVal flag1Column As Long, ByVal flag2Column As Long, ByVal rowIndex As Long) As Long

    Dim flagToApplyNext As Long
    If flagToApply = 1 Then
        Cells.Item(rowIndex, flag1Column).Value = "FLAG1"
        flagToApplyNext = 2
    Else
        Cells.Item(rowIndex, flag2Column).Value = "FLAG2"
        flagToApplyNext = 1
    End If

    ApplyFlagValue = flagToApplyNext
End Function

Private Function GetColumnNumber(ws As Worksheet, headerLabel As String) As Long
    GetColumnNumber = Application.WorksheetFunction.Match(headerLabel, ws.Range("1:1"), 0)
End Function

Private Function IsBlank(theCell As Range) As Boolean
    IsBlank = Trim(theCell.Value) = ""
End Function
...