Excel VBA在条件满足时插入新行并在满足条件的地方填充颜色

Question

Option Explicit

Sub InsertRowBelowNegativeEntriesInFGHI()

    Dim lLastColRow As Long
    Dim lLastRow As Long
    Dim lColIndex As Long
    Dim lRowIndex As Long
    Dim bInsert As Boolean
    Dim bIsBalanceRow As Boolean
    Dim vFPos As Variant
    Dim vGPos As Variant
    Dim vHPos As Variant
    Dim vIPos As Variant
    Dim vJPos As Variant
    Dim vKPos As Variant
    Dim vLPos As Variant
    Dim vMPos As Variant
    Dim vNPos As Variant
    Dim vOPos As Variant
    Dim vPPos As Variant
    Dim vQPos As Variant
    Dim vRPos As Variant
    Dim vSPos As Variant
    Dim vTPos As Variant
    Dim sTrigger As String

    For lColIndex = 6 To 10
        lLastColRow = Cells(Rows.Count, lColIndex).End(xlUp).Row
        If lLastColRow > lLastRow Then lLastRow = lLastColRow
    Next

    For lRowIndex = lLastRow - 1 To 2 Step -1
        If UCase(Cells(lRowIndex, 1).Value) = "BALANCE" Then
            'On a BALANCE row
            bInsert = False
            vFPos = Cells(lRowIndex, "F").Value
            vGPos = Cells(lRowIndex, "G").Value
            vHPos = Cells(lRowIndex, "H").Value
            vIPos = Cells(lRowIndex, "I").Value
            vJPos = Cells(lRowIndex, "J").Value

            If vFPos < 0 And (vGPos > 0 Or vHPos > 0 Or vIPos > 0 Or vJPos > 0) Then bInsert = True: 'sTrigger = "F"
            If vGPos < 0 And (vHPos > 0 Or vIPos > 0 Or vJPos > 0) Then bInsert = True: 'sTrigger = "G"
            If vHPos < 0 And (vIPos > 0 Or vJPos > 0) Then bInsert = True: 'sTrigger = "H"
            If vIPos < 0 And (vJPos > 0) Then bInsert = True: 'sTrigger = "I"

            If bInsert Then
                Cells(lRowIndex + 1, 1).EntireRow.Insert , CopyOrigin:=xlFormatFromLeftOrAbove
                'Debug.Print lRowIndex, sTrigger
            End If

        End If
    Next
    For lColIndex = 11 To 15
        lLastColRow = Cells(Rows.Count, lColIndex).End(xlUp).Row
        If lLastColRow > lLastRow Then lLastRow = lLastColRow
    Next

    For lRowIndex = lLastRow - 1 To 2 Step -1
        If UCase(Cells(lRowIndex, 1).Value) = "BALANCE" Then
            'On a BALANCE row
            bInsert = False
            vKPos = Cells(lRowIndex, "K").Value
            vLPos = Cells(lRowIndex, "L").Value
            vMPos = Cells(lRowIndex, "M").Value
            vNPos = Cells(lRowIndex, "N").Value
            vOPos = Cells(lRowIndex, "O").Value

            If vKPos < 0 And (vLPos > 0 Or vMPos > 0 Or vNPos > 0 Or vOPos > 0) Then bInsert = True: 'sTrigger = "K"
            If vLPos < 0 And (vMPos > 0 Or vNPos > 0 Or vOPos > 0) Then bInsert = True: 'sTrigger = "L"
            If vMPos < 0 And (vNPos > 0 Or vOPos > 0) Then bInsert = True: 'sTrigger = "M"
            If vNPos < 0 And (vOPos > 0) Then bInsert = True: 'sTrigger = "N"

            If bInsert Then
                Cells(lRowIndex + 1, 1).EntireRow.Insert , CopyOrigin:=xlFormatFromLeftOrAbove
                'Debug.Print lRowIndex, sTrigger
            End If

        End If
    Next
    For lColIndex = 16 To 20
        lLastColRow = Cells(Rows.Count, lColIndex).End(xlUp).Row
        If lLastColRow > lLastRow Then lLastRow = lLastColRow
    Next

    For lRowIndex = lLastRow - 1 To 2 Step -1
        If UCase(Cells(lRowIndex, 1).Value) = "BALANCE" Then
            'On a BALANCE row
            bInsert = False
            vPPos = Cells(lRowIndex, "P").Value
            vQPos = Cells(lRowIndex, "Q").Value
            vRPos = Cells(lRowIndex, "R").Value
            vSPos = Cells(lRowIndex, "S").Value
            vTPos = Cells(lRowIndex, "T").Value

            If vPPos < 0 And (vQPos > 0 Or vRPos > 0 Or vSPos > 0 Or vTPos > 0) Then bInsert = True: 'sTrigger = "P"
            If vQPos < 0 And (vRPos > 0 Or vSPos > 0 Or vTPos > 0) Then bInsert = True: 'sTrigger = "Q"
            If vRPos < 0 And (vSPos > 0 Or vTPos > 0) Then bInsert = True: 'sTrigger = "R"
            If vSPos < 0 And (vTPos > 0) Then bInsert = True: 'sTrigger = "S"

            If bInsert Then
                Cells(lRowIndex + 1, 1).EntireRow.Insert , CopyOrigin:=xlFormatFromLeftOrAbove
                'Debug.Print lRowIndex, sTrigger
            End If

        End If
    Next
End Sub

我正在使用上面的代码来查找余额行的 FGHIJ、KLMNO、PQRST 列中是否有任何负值后跟任何正值。在 A 列中有多个余额行。

上面的代码正在工作，当有任何负值后跟从左到右的任何正值时，它会在 Balance 上方插入一个新行。但是对于 PQRST 列(对于第 16-20 列)它不起作用，我不知道为什么以及代码中需要什么更改？

如果条件满足，我想添加 2 行，而不是在所有 3 个分类列中添加 1 行 (FGHIJ) (KLMNO) (PQRST)

我想在第一个空白添加行的 A 列中有一个单词“通过调整”。

我希望该部分应填充为满足条件的绿色。

例如在 F6 G6 H6 I6 J6
值为 0 -10 100 0 10

这里将添加 2 个新行
那么 F6 G6 H6 I6 J6 应该用绿色填充。

满足条件的地方应该用绿色着色，并且应该插入两个空白行。

Answer 1

当子例程像您一样复杂时，您应该简化将任务委派给其他子例程和功能。

Sub InsertRowBelowNegativeEntriesInFGHI2()
    Dim lLastRow As Long, lRowIndex As Long
    Dim InsertF As Boolean, InsertK As Boolean, InsertP As Boolean

    lLastRow = Range(Columns(6), Columns(20)).Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row

    For lRowIndex = lLastRow To 2 Step -1
        If UCase(Cells(lRowIndex, 1).Value) = "BALANCE" Then
            InsertF = ShouldInsert(lRowIndex, "F")
            InsertK = ShouldInsert(lRowIndex, "K")
            InsertP = ShouldInsert(lRowIndex, "P")

            If InsertF And InsertK And InsertP Then
                Rows(lRowIndex & ":" & lRowIndex + 1).Insert , CopyOrigin:=xlFormatFromLeftOrAbove

                Range(Cells(lRowIndex, "F"), Cells(lRowIndex + 1, "T")).Interior.Color = vbGreen
                Cells(lRowIndex, 1) = "By Adjustment"
                Cells(lRowIndex, 1).Offset(1) = "By Adjustment"
            ElseIf InsertF Or InsertK Or InsertP Then
                Rows(lRowIndex).Insert , CopyOrigin:=xlFormatFromLeftOrAbove

                If InsertF Then Range(Cells(lRowIndex, "F"), Cells(lRowIndex, "J")).Interior.Color = vbGreen
                If InsertK Then Range(Cells(lRowIndex, "K"), Cells(lRowIndex, "O")).Interior.Color = vbGreen
                If InsertP Then Range(Cells(lRowIndex, "P"), Cells(lRowIndex, "T")).Interior.Color = vbGreen

                Cells(lRowIndex, 1) = "By Adjustment"
            End If
        End If

    Next

End Sub

Function ShouldInsert(xRow As Long, firstColumnLetter As String) As Boolean
    Dim y As Integer
    Dim bNegative
    Dim c As Range
    Set c = Cells(xRow, firstColumnLetter)
    Dim a(4) As Double

    For y = 0 To 3
        If c.Offset(0, y) < 0 Then bNegative = True

        If bNegative And c.Offset(0, y + 1) > 0 Then
            ShouldInsert = True
            Exit Function
        End If

    Next

End Function

Function OldShouldInsert1(xRow As Long, firstColumnLetter As String) As Boolean
    Dim c As Range
    Set c = Cells(xRow, firstColumnLetter)

    ShouldInsert = (c.Offset(0, 0).Value < 0 And (c.Offset(0, 1) > 0 Or c.Offset(0, 2) > 0 Or c.Offset(0, 3) > 0 Or c.Offset(0, 4) > 0)) _
    Or (c.Offset(0, 2).Value < 0 And (c.Offset(0, 3) > 0 Or c.Offset(0, 4))) _
    Or (c.Offset(0, 3).Value < 0 And (c.Offset(0, 4) > 0 Or c.Offset(0, 5) > 0)) _
    Or (c.Offset(0, 4).Value < 0 And (c.Offset(0, 4) > 0))

End Function