为每个值> 0添加/复制下面的行

Question

所以我使用Excel VBA来构建简单的宏，但是现在它对我来说有点太复杂了。我想每次在F列中直到J出现某个值时都复制一行。因此，如果F列的第2行的单元格值> 0，则需要复制下面的整个行以获取G列中的单元格值，直到J.如果G列第2行的单元格值也大于0，则需要再次复制整个行以获取F列，H列的单元格值，直到J。下面的图片显示了我真正想要实现的目标。

经过数天的反复尝试，使用了不同的代码，我发现以下vba代码插入了空白行，而没有复制其上方的行。

 Sub Add_Rows()
  Dim r As Long

  Application.ScreenUpdating = False
  For r = Range("F:G" & Rows.Count).End(xlUp).Row To 4 Step -1
    If Cells(r, "f:G").Value > 0 Then Rows(r + 1).Resize(Cells(r, "G").Value).Insert
  Next r
  Application.ScreenUpdating = True
End Sub

我如何调整此代码以使其完全与示例相同？

Answer 1

您不希望您的程序不必要地搜索工作簿中的每一行。相反，您应该搜索直到到达具有值的最后一行。我已经编写了一个函数，该函数使用给定工作表中的值查找最后一行。看起来像这样：

'Returns the last row in the specified sheet containing a value
Function returnLastRow(ByVal sheetName As String, countCol As Integer) As Long
    With Sheets(sheetName)
        returnLastRow = .Cells(.Rows.Count, countCol).End(xlUp).row
    End With
End Function

该函数将传递您要在其中搜索的工作表名称和列，并返回具有值的最后一行。示例函数调用在工作表的第一列中显示为“ work”，并返回包含值的最后一行：

bottomRow = returnLastRow("work", 1)

现在，我们可以将bottomRow变量传递给Add_Rows（）子例程，该例程可以用来缩小将要操作的范围。遍历动态范围时，最好使用Range.cells() property，因为我们可以在数字上引用行和列。这是我修改子例程的方法：

Sub Add_Rows(ByVal sheetName As String, bottomRow As Long)
    With Sheets(sheetName)
        For ctr = 1 To bottomRow
            If (.Cells(ctr, 10).Value > 0) Then
                'insert a blank row
                .Rows(ctr + 1 & ":" & ctr + 1).Insert
                '+1 to bottomRow since we've added a new row.
                bottomRow = bottomRow + 1
                'Copy information from ctr row
                .Range(.Cells(ctr, 1), .Cells(ctr, 5)).Copy
                'Add to new row
                .Range(.Cells(ctr + 1, 1), .Cells(ctr + 1, 5)).PasteSpecial xlPasteAll
            End If
        Next ctr
    End With
End Sub