Excel VBA跳过连续发生的事件

我有一个Excel数据表，其中包含以下内容：

第1行：表格标题

A2:A50001活动日期

B2:B50001编号（标准1）

C2:C50001编号（标准2）

E2:E50001目标单元格（标志1）

D2:D50001目标日期1

G2:G50001靶细胞（标志2）

F2:F50001目标日期2

注：A2:G50001可能包含有错误或空白的单元格

我想做一个常规的工作 当标准2的值大于标准1的值时 并且标准1的值大于前一行标准1的值 然后将“标志1”添加到E列上同一行的单元格中 当标准2的值小于等于标准1的值时 标准1的值小于等于前一行标准1的值 然后将“标志2”添加到G列上同一行的单元格中

在这里，我为此编写了一个宏

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

Sub-add_-flag_与_-criteria_1_-2（）
作为整数的Dim i
添加此行后，将Dt变暗为“长”
将Cr1变暗为长
黯淡的Cr2如长
暗淡的旗子1一样长
暗淡的旗子2一样长
日期尽可能长
日期尽可能长
屋顶和屋顶一样长
屋顶和屋顶一样长
添加此行后，变暗LR
将ws设置为工作表
设置ws=工作表（“标准”）
LR=Application.WorksheetFunction.CountA（ws.Range（“A1:A50001”））”添加了此行
Dt=Application.WorksheetFunction.Match（“日期”，ws.Range（“1:1”），0）”添加此行
Cr1=Application.WorksheetFunction.Match（“标准1”，ws.Range（“1:1”），0）
Cr2=Application.WorksheetFunction.Match（“标准2”，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）
对于i=2至LR
F1roof=Application.WorksheetFunction.Max（ws.Range（单元格（2,4），单元格（i,4）））”添加了此行
F2roof=Application.WorksheetFunction.Max（ws.Range（单元格（2,6），单元格（i,6）））”添加了此行
如果单元格（i，Cr2）>单元格（i，Cr1）和单元格（i，Cr1）>单元格（i-1，Cr1）且不小于F2roof，则单元格（i，F1date）。值=单元格（i，Dt）。值
如果单元格（i，Cr2）>单元格（i，Cr1）和单元格（i，Cr1）>单元格（i-1，Cr1）且不F2roof如果细胞（i，Cr2）尝试一下。应用更具描述性的名称，并将声明移动到更接近使用它们的位置

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

选项显式
子添加_标志_和_标准_1_2（）
将ws设置为工作表
设置ws=工作表。[_默认值]（“标准”）
与列一样长
dateColumn=GetColumnNumber（ws，“日期”）
模糊标准1列的长度
criteria1Column=GetColumnNumber（ws，“CRITERIA1”）
模糊标准2列的长度为
criteria2Column=GetColumnNumber（ws，“CRITERIA2”）
暗淡的Flag1列与长
flag1Column=GetColumnNumber（ws，“flag1”）
暗淡的Flag2列与长
flag2Column=GetColumnNumber（ws，“flag2”）
Dim FLAG1DATE列的长度相同
flag1DateColumn=GetColumnNumber（ws，“F1date”）
Dim FLAG2DATE列的长度为
flag2DateColumn=GetColumnNumber（ws，“F2date”）
昏暗的旗子1与地面一样长
暗淡的旗子2与长的旗子一样宽
暗淡的旗子和它一样长
flagToApply=0
将行索引设置为整数
最后一排一样长
lastRow=Application.WorksheetFunction.CountA（ws.Range（“A1:A50001”））
对于rowIndex=2到lastRow
如果不是BlankOrError（ws、rowIndex、Criteria1列、Criteria2列），则
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）））
如果未标记2 ateroof<标记1 ateroof并标记为应用1，则
如果ws.Cells.Item（rowIndex，Criteria2列）.Value>ws.Cells.Item（rowIndex，Criteria1列）.Value和Cells.Item（rowIndex，Criteria1列）>Cells.Item（rowIndex-1，Criteria1列），则
如果flagToApply=0，则flagToApply=1
ws.Cells.Item（rowIndex，flag1DateColumn）.Value=ws.Cells.Item（rowIndex，dateColumn）.Value
flagToApply=ApplyFlagValue（flagToApply、Flag1列、Flag2列、rowIndex）
如果结束
如果结束
如果未标记1 ateroof<标记2 ateroof并标记2，则
如果ws.Cells.Item（rowIndex，criteria2Column）尝试一下。应用更具描述性的名称，并将声明移动到更接近使用它们的位置

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

选项显式
子添加_标志_和_标准_1_2（）
将ws设置为工作表
设置ws=工作表。[_默认值]（“标准”）
与列一样长
dateColumn=GetColumnNumber（ws，“日期”）
模糊标准1列的长度
criteria1Column=GetColumnNumber（ws，“CRITERIA1”）
模糊标准2列的长度为
criteria2Column=GetColumnNumber（ws，“CRITERIA2”）
暗淡的Flag1列与长
flag1Column=GetColumnNumber（ws，“flag1”）
暗淡的Flag2列与长
flag2Column=GetColumnNumber（ws，“flag2”）
Dim FLAG1DATE列的长度相同
flag1DateColumn=GetColumnNumber（ws，“F1date”）
Dim FLAG2DATE列的长度为
flag2DateColumn=GetColumnNumber（ws，“F2date”）
昏暗的旗子1与地面一样长
暗淡的旗子2与长的旗子一样宽
暗淡的旗子和它一样长
flagToApply=0
将行索引设置为整数
最后一排一样长
lastRow=Application.WorksheetFunction.CountA（ws.Range（“A1:A50001”））
对于rowIndex=2到lastRow
如果不是BlankOrError（ws、rowIndex、Criteria1列、Criteria2列），则
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）））
如果未标记2 ateroof<标记1 ateroof并标记为应用1，则
如果ws.Cells.Item（rowIndex，criteria2Column）.Value>ws.Cells.It