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而不是{{1} }。我还不太清楚VBA还能让它发挥作用。

有什么建议吗？谢谢！

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

Answer 1

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

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

Sheet1：

Sheet3：

编辑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

Answer 2

使用范围i的{{3}}属性获取i的下一行：

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

修改：您可以使用它来复制所有行，直到您下次见到＆＃34; HERE＆＃34;：

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

Sheet 1中：

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

HERE |      |    
22   |  22  |  22

表Sheet 3：

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

Edit2：它会复制字下面的所有行＆＃34; here＆＃34; （不区分大小写，请注意使用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

Sheet 1中：

A | B | C HERE | | 11 | 11 | 11 33 | 33 | 33 55 | 55 | 55 HERE | | 22 | 22 | 22 44 | 44 | 44

表Sheet 3：

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

Excel VBA - 循环以将行复制到特定值之下

2 个答案: