Excel VBA - Loop to copy row beneath certain value

Question

I have a spreadsheet that will have multiple header-style rows in it. I want to copy the row beneath each header using a script. I currently have this from a 3 year old StackOverflow answer:

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

This works, except it copies the header itself (HERE), and not the data beneath it. I'm still new to VBA, so I'm not sure how to adjust this. I've tried something like Dim j As Integer, then j = i + 1 and j.EntireRow etc, but that doesn't work because i is Range and not Integer. I don't know enough about VBA yet to get this working.

Any advice? Thank you!

EDIT: In addition to the scenario when I copy just the first row beneath the header, can I also modify this to copy x rows beneath the header? For example, once it finds the header, copy the next three rows. Thanks again!

Answer 1

use Offset(1, 0) property with Range i to get next row down the i:

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

Edit: You can use this to copy all rows until you meet next "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

Sheet1:

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

HERE |      |    
22   |  22  |  22

Sheet3:

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

Edit2: It copies all the rows immediately below the word "here" (case-insensitive, note the use of 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

Sheet1:

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

55   |  55  |  55

HERE |      |    
22   |  22  |  22

44   |  44  |  44    

Sheet3:

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

Answer 2

As per my understandings i modified as below.

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 :

EDIT 1

If you want to copy the rows until another HERE in a column, then replace the below code. it will work.

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