Question

我有以下代码，效果很好。它解析我的所有工作表并找到我想要的A列中的行并将其粘贴到指定的工作表。但是，我需要它来复制指定的行加上下一个X行。有人能帮助我做到这一点吗？

Sub FindValues()
    Dim ws As Excel.Worksheet
    Dim LastRow As Long
    Dim i As Integer

    For Each ws In Application.ThisWorkbook.Worksheets
        LastRow = ws.Cells(Rows.Count, 1).End(xlUp).Row
        i = 1

        Do While i <= LastRow
            If ws.Range("A" & i).Value = "OwnershipType Ownership Type" Then
                ws.Rows(i).Copy Sheets("Summary").Range("A2")
                i = i - 1
                LastRow = LastRow - 1
            End If
            i = i + 1
        Loop
    Next


End Sub

Answer 1

您可以修改此行上复制的行范围，如下所示：

ws.Rows(i & ":" & i + 3).Copy Sheets("Summary").Range("A2")

例如，如果在第1行中找到匹配项，代码将呈现为ws.Rows(1:4).Copy

Answer 2

我做了一些小修改。刚刚添加了（i +要复制的行数）。检查以下代码：在代码中使用了Integer copyrw ，您可以设置此整数来复制行数。

Sub FindValues()
    Dim ws As Excel.Worksheet
    Dim LastRow As Long
    Dim i As Integer
    Dim copyrw as Integer

copyrw = 3
For Each ws In Application.ThisWorkbook.Worksheets
    LastRow = ws.Cells(Rows.Count, 1).End(xlUp).Row
    i = 1

    Do While i <= LastRow
        If ws.Range("A" & i).Value = "OwnershipType Ownership Type" Then
            ws.Rows(i & ":" & i + copyrw).Copy Sheets("Summary").Range("A2")
            i = i - 1
            LastRow = LastRow - 1
        End If
        i = i + 1
    Loop
Next


End Sub

复制行加下一个3

2 个答案: