Excel VBA: Dynamic range cut and paste

Question

Relative novice here in VBA, in need of some assistance modifying code to fit a specific use case. I've searched high and low in addition with tinkering with code but to date have been unsuccessful in locating a similar use case // executing the necessary changes on my own.

Use Case: Have an exported report that generates multiple reports within a single worksheet all separated by a single blank space after a row that contains totals. The names of each report are static but the amount of data contained within each report is dynamic (how many rows it can contain).

I need code that searches Column "A" in Sheet1 for a specific value (example in the attached image it would be "Extra Header A" for a report title). Then copies (preferably) from the next row under "Extra Header A" down to the blank space under the row with "Data 9" and from the columns with "Header B" to "Header E" into Sheet2("A1").

Use Case Image:

The code listed below is what I have found moderate success with (sorry source is unavailable as I've Frankensteined this together). The current issue with this code is it appears to only be static in nature (by modifying the if statement range method) and does not account for the number of rows within each report being dynamic.

Sub Cells_Loop()

Dim c As Range, lastrow As Long


lastrow = Cells(Rows.Count, 1).End(xlUp).Row

Application.ScreenUpdating = False

For Each c In Range("A1:A500" & lastrow)
    If c.Value = "Extra Header A" Then Range("A" & c.Row & ":D" & c.Row).Copy Worksheets("Sheet2").Range("A" & 1)
Next c

Worksheets("Sheet2").Rows(1).Delete Shift:=xlUp

Application.ScreenUpdating = True

End Sub

Any help offered would be greatly appreciated! Thanks in advance.

edit added another image for additional context. Red would be data I'm looking to avoid, while blue is the targeted data. Image 2

Answer 1

To not have it copy empty rows (assuming the blanks are in column B)

For Each c In Range("A1:A" & lastrow)
    'Makes sure it's not blank
    If Range("B" & c.Row).Value <> "" Then
        If c.Value = "Extra Header A" Then 
            Range("A" & c.Row & ":D" & c.Row).Copy Worksheets("Sheet2").Range("A" & 1)
        End If
    End If
Next c

EDIT: Okay, I have rewritten your snippet of code:

Option Explicit
Sub Test()
Application.ScreenUpdating = False

Dim i As Integer, j As Integer, lastrow As Long
lastrow = Cells(Rows.Count, "A").End(xlUp).Row

For i = 1 To lastrow
    If Range("A" & i).Value = "Extra Header A" Then
        For j = i To lastrow
            If Range("A" & j).Value = "" Then
                Worksheets("Sheet2").Range("A1:D" & j - 1 - i).Value = Worksheets("Sheet1").Range("A" & i & ":D" & j - 1).Value
            End If
        Next j
    End If
Next i

'Don't need shift up
Worksheets("Sheet2").Rows(1).Delete

Application.ScreenUpdating = True
End Sub

PLEASE NOTE How I've added formatting, used Option Explicit to make sure I'm referencing my variables correctly, I've moved lines that mess with Application to the front and end of the sub, and I've gotten rid of using Copy by instead just using direct references to the values.

Before & After:

If you want to keep the TOTALS row, just get rid of the minus 1s next to the js. I wasn't sure if you wanted that included because of the empty cell in column A.

Answer 2

Also (besides dwirony's correct observation), your copy is only going to copy one row of data (c.row) Change the range, Range("A" & c.Row & ":D" & c.Row) to Range("A" & c.Row & ":D" & lastrow)

Cells_Loop()
Dim c As Range, lastrow As Long
lastrow = Cells(Rows.Count, 1).End(xlUp).Row
Application.ScreenUpdating = False
'c.row
For Each c In Range("A1:A" & lastrow)
    If c.Value = "Extra header" Then 
        Range("A" & c.Row & ":D" & lastrow).Copy Worksheets("Sheet2").Range("A1")
    End If
Next c
Worksheets("Sheet2").Rows(1).Delete Shift:=xlUp
Application.ScreenUpdating = True
End Sub

Answer 3

Instead of checking all the cells individually, you can use build-in tools like this:

Sub test()
  With Worksheets("Sheet1")
    Dim x As Range
    Set x = .Columns(1).Find("Extra Header A", , xlValues, 1, , , 1).Offset(1)
    .Range(x, x.End(xlDown).Offset(1, 3)).Copy Worksheets("Sheet2").Cells(1)
  End With
End Sub

Should also a bit faster. ;)