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!

can you show your headers? and data to be copied to sheet 3? so that it will be easy to understand — Karthick Gunasekaran, Jun 25 '16 at 06:12
@NanAvanIllai I believe the first cell in the header will always be "Item Number". That would be my indication that the very next row will be what I want to copy. Please also see my edit. — pez, Jun 25 '16 at 06:14

Karthick Gunasekaran · Answer 1 · 2016-06-25T07:07:11.777

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

This looks good, thank you. Do you know how you would modify it then to copy all rows beneath "HERE" until it reaches another "HERE"? At which point it would continue the process — pez, Jun 25 '16 at 06:39
if you want to copy 2nd row to 1000 then it would be `Range(Cells(2, i), Cells(1001, i)).Copy`. Hope it helps — Karthick Gunasekaran, Jun 25 '16 at 06:52

Ajeet Shah · Accepted Answer · 2016-06-26T06:04:12.250

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

Looks good I'll test soon and let you know. Didn't know offset could be used that way — pez, Jun 25 '16 at 06:50
Your edit works well except for one small catch - the `ElseIf` will copy other rows in the workbook that have a non-blank value in column A. I would only want the `ElseIf` to copy rows with non-blank values in column A if they're directly beneath the row that has "HERE" in column A. Any ideas? Thank you. — pez, Jun 25 '16 at 14:41
[This](http://stackoverflow.com/a/37853893/2873538) and [this](http://stackoverflow.com/a/21106055/2873538) might be a good read to understand the **Edit2**. I hope it fulfills your requirement. — Ajeet Shah, Jun 26 '16 at 05:02

Excel VBA - Loop to copy row beneath certain value

2 Answers2