Excel VBA - 循环复制低于特定值的行

Question

我有一个电子表格，其中包含多个标题样式的行。我想使用脚本复制每个标题下方的行。我目前有一个 3 岁的 StackOverflow 答案：

Private Sub CommandButton4_Click()

    Dim i As Range

    For Each i In Sheet1.Range("A1:A1000")
        Select Case i.Value
            Case "HERE"
                Sheet3.Range("A" & Sheet3.Rows.Count).End(xlUp).Offset(1, 0).EntireRow.Value = i.EntireRow.Value
            Case Else

        End Select
     Next i

End Sub

这可行，除了它复制标题本身（HERE），而不是它下面的数据。我还是 VBA 的新手，所以我不知道如何调整它。我尝试过类似Dim j As Integer，然后是j = i + 1 和j.EntireRow 等，但这不起作用，因为i 是Range 而不是Integer。我对 VBA 的了解还不够，无法使其正常工作。

有什么建议吗？谢谢！

编辑：除了复制标题下方第一行的情况之外，我还可以修改它以复制标题下方的x 行吗？例如，一旦找到标题，复制接下来的三行。再次感谢！

Answer 1

使用Offset(1, 0) 属性和范围i 来获取i 的下一行：

Sheet3.Range("A" & Sheet3.Rows.Count).End(xlUp).Offset(1, 0).EntireRow.Value = i.Offset(1, 0).EntireRow.Value

编辑：您可以使用它来复制所有行，直到遇到下一个“HERE”：

Private Sub CommandButton4_Click()

    Dim i As Range

    For Each i In Sheet1.Range("A1:A5")

        If i.Value = "HERE" Then
            Sheet3.Range("A" & Sheet3.Rows.Count).End(xlUp).Offset(1, 0).EntireRow.Value = i.Offset(1, 0).EntireRow.Value
        ElseIf i.Value <> "" Then
            Sheet3.Range("A" & Sheet3.Rows.Count).End(xlUp).Offset(1, 0).EntireRow.Value = i.EntireRow.Value
        Else
            'Else is optional, feel free to remove if not required
        End If

     Next i

End Sub

表 1：

 A   |   B  |  C
HERE |      |   
11   |  11  |  11
33   |  33  |  33

HERE |      |    
22   |  22  |  22

表 3：

 A   |   B  |  C
11   |  11  |  11
33   |  33  |  33 
22   |  22  |  22

Edit2：它复制所有行紧接着单词“here”（不区分大小写，注意使用UCase）：

Private Sub CommandButton4_Click()

    Dim i As Long
    Dim j As Long
    Dim lastRow As Long
    Dim blankRow As Long

    i = 1
    lastRow = Sheet1.Range("A" & Sheet1.Rows.Count).End(xlUp).Row
    blankRow = Sheet3.Range("A" & Sheet3.Rows.Count).End(xlUp).Row + 1

    Do While True

        If UCase(Sheet1.Range("A" & i).Value) = "HERE" Then

            j = Sheet1.Range("A" & i).End(xlDown).Row

            Union(Sheet1.Range("A" & i + 1).EntireRow, Sheet1.Range("A" & j).EntireRow).Copy
            Sheet3.Range("A" & blankRow).PasteSpecial xlValue

            blankRow = Sheet3.Range("A1").End(xlDown).Row + 1
            i = j + 1

        Else
            i = i + 1
        End If

        If i >= lastRow Then
            Exit Do
        End If

    Loop

End Sub

表 1：

 A   |   B  |  C
HERE |      |   
11   |  11  |  11
33   |  33  |  33

55   |  55  |  55

HERE |      |    
22   |  22  |  22

44   |  44  |  44    

表 3：

 A   |   B  |  C
11   |  11  |  11
33   |  33  |  33 
22   |  22  |  22

Answer 2

根据我的理解，我修改如下。

Private Sub CommandButton4_Click()
    Dim i As Long
    lastcolumn = Cells(1, Columns.Count).End(xlToLeft).Column
    For i = 1 To lastcolumn
        If Cells(1, i) = "HERE" Then
            Range(Cells(2, i), Cells(4, i)).Copy Sheet3.Range("A" & Sheet3.Range("A" & Rows.Count).End(xlUp).Row + 1) ' Here i have copied 2nd row to 4th row. Modify this as per your wish
        End If
    Next i
End Sub

---

表 1：

表 3：

编辑 1

如果要将行复制到列中的另一个 HERE，请替换以下代码。它会起作用的。

Private Sub CommandButton4_Click()
    Dim i As Long
    lastcolumn = Cells(1, Columns.Count).End(xlToLeft).Column
    For i = 1 To lastcolumn
        If Cells(1, i) = "HERE" Then
            'lastrow = Columns(i).SpecialCells(xlLastCell).Row
            lastrow = Columns(i).Find("HERE").Row
            Range(Cells(2, i), Cells(lastrow, i)).Copy Sheet3.Range("A" & Sheet3.Range("A" & Rows.Count).End(xlUp).Row + 1)
        End If
    Next i
End Sub