Macro to copy and paste changing number of rows

**phil3061** · 04-05-2012, 02:13 PM

Hello,

I'm looking for help for a macro that will copy and paste a range of data onto a new sheet. I've attached the workbook, with some sample data. Basically what I need is for each header, ie "Mega AHT", copy the data below it (A3 - F7) then paste it onto a new sheet. Then come back and grab "Inet AHT" (A9 - F14), copy and paste it onto a new sheet.

This is a daily report, so the range of the data changes daily. Any help would be greatly appreciated.

**DGagnon** · 04-05-2012, 02:57 PM

Try this Macro out

Sub CopyToNewSheet()
Dim WS As Worksheet

i = 1
Start = 1
With Worksheets("CRC_OpsScorecard_Macro")
    Do Until i > .Range("A1000").End(xlUp).Row
        Set WS = Sheets.Add
        WS.Name = .Range("A" & i).Value
        
        Do Until .Range("A" & i).Value = "Period to Date"
            i = i + 1
        Loop
        
        .Range("A" & Start & ":A" & i).EntireRow.Copy Destination:=WS.Range("A1")
        Start = i + 1
        i = i + 1
    Loop
End With

End Sub

**Dennis7849** · 04-05-2012, 02:59 PM

How many blocks are there that need to be setup on their own sheets?

Are the number of rows for each block always the same(like always 7 rows tall)??

**Richard Buttrey** · 04-05-2012, 03:22 PM

Hi,

One way

Sub CopyToSheets()
    Dim lFirstRow As Long, llastrow As Long, lEndRow As Long, lRow As Long, stHeader As String
    lEndRow = Range("A" & Rows.Count).End(xlUp).Row
    lRow = 1
    
    Do Until lRow > lEndRow
        If Left(Sheet1.Range("A" & lRow), 4) = "Days" Then
            lFirstRow = lRow - 1
            stHeader = Sheet1.Range("A" & lFirstRow)
        End If
        If Left(Sheet1.Range("A" & lRow), 6) = "Period" Then
            llastrow = lRow
        End If
        
        lRow = lRow + 1

        If llastrow > lFirstRow Then
            Sheet1.Range("A" & lFirstRow & ":A" & llastrow).EntireRow.Copy
            Sheets.Add after:=Sheets(Sheets.Count)
            ActiveSheet.Paste
            ActiveSheet.Name = stHeader
            lFirstRow = llastrow
        End If
    Loop