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
我正在使用上面的代码来查找是否有任何negetive值后跟FGHIJ，KLMNO，PQRST列中的任何正值。在A列中有多个平衡行。
上面的代码正常工作，当有任何负值后跟任何正值从左到右时，它会在上面的Balance中插入一个新行。但是对于PQRST专栏（第16-20栏）它不起作用，我不知道为什么＆amp;该代码中所需的更改应该是什么？
例如在F6 G6 H6 I6 J6中 值为0 -10 100 0 10
此处将添加2个新行 那么F6 G6 H6 I6 J6应该用绿色填充。
凡满足条件的地方都应涂上绿色，并插入两个空白行。
答案 0 :(得分：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