Excel VBA: Dynamic range cut and paste

1
votes

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:

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

3
vbaexcel
For Each c In Range("A1:A500" & lastrow) makes no sense. Change it to For Each c In Range("A1:A" & lastrow) to make it dynamic. Also, you have an If statement with no End If. ALSO, what's the point of the delete line outside of your loop??? – dwirony
Dwirony, thank you for pointing out the End If got that fixed up. The delete line removes the "Extra Header A" line that gets copied over from my original code submission as it is not needed. Thank you again for the help so far. Still unfortunately need an idea on how to add a break point for copying once it reaches a blank row. Continues to pull in all remaining rows on the sheet even once it hits a blank line (carries over into the next report on the sheet). – Rich L
Where are the blank cells, any cell in B-D? – dwirony
Which ever is easier to accomplish I will take: Could be the blank cell that is under "Header B" on the Totals line Or.. Could be the row directly below the Totals line. No matter what though there will be another report generated (that I need to avoid) immediately following the 'blank line' after the totals line. I hope that makes sense. – Rich L
See my answer below. If the cell in column B is blank, it'll skip that row. – dwirony

3 Answers

2
votes

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:

BeforeAfter

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.

1
votes

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
0
votes

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. ;)