create macro that will convert excel rows from single sheet to new sheets

Question

I need to create macro that will convert excel rows from single sheet to new sheets.

I have 3 Rows of headers followed by lots of rows of data.

I would like to place each row on this sheet "Dept" into new sheets of their own (with the exception of the header rows). On each new sheet created, I would like the top 3 rows (the headers) repeated and formatting copied (if possible), then the single corresponding row from the "Dept" sheet. I would also like the new sheets to be named the value entered in column A (ie Ceiling Lights or Wall Lights from the example below).

I have no macro experience, so I'm having trouble taking code from previous answers and trying to apply it to my cause. Thanks for the help!

       A           B           C          D

1. dept template // promos // quicklinks // main banner

2. where found // content slot // category // attributes

3. blank // content asset // html // hero image

4. Ceiling Lights // value // value // value

5. Wall Lights // value // value // value

6. Floor Lights // value // value // value

Converted to new sheets in the same workbook that have a single row after the 3 header rows:

new sheet named: Ceiling Lights

       A           B           C          D

1. dept template // promos // quicklinks // main banner

2. where found // content slot // category // attributes

3. blank // content asset // html // hero image

4. Ceiling Lights // value // value // value

new sheet named: Wall Lights

       A           B           C          D

1. dept template // promos // quicklinks // main banner

2. where found // content slot // category // attributes

3. blank // content asset // html // hero image

4. Wall Lights // value // value // value

Here's the code I have so far...

Sub Addsheets()
Dim cell As Range
Dim b As String
Dim e As String
Dim s As Integer
Sheets("Dept").Select
a = "a4"
e = Range(a).End(xlDown).Address 'get's address of the last used cell
 'loops through cells,creating new sheets and renaming them based on the cell value
For Each cell In Range(a, e)
    s = Sheets.Count
    Sheets.Add After:=Sheets(s)
    Sheets(s + 1).Name = cell.Value
Next cell

Application.CutCopyMode = True

Dim Counter As Long, i As Long

Counter = Sheets.Count
For i = 1 To Counter
    Sheets("Dept").Cells(1, 3).EntireRow.Copy
    Sheets(i).Cells(1, 3).PasteSpecial

Next i

Application.CutCopyMode = False
End Sub

I can get the new sheets to create and name based on the cells in column A with the top portion of code, but when I tried adding code to have the first three rows (the header rows) copy to each of these newly created sheets I get Error 9 Subscript out of range for: Sheets(i).Cells(1, 3).PasteSpecial.

Not sure how to fix? Also, is there a way to preserve the header formatting (column widths)?

Answer 1

Is this what you are trying?

Option Explicit

Sub Sample()

    Dim ws As Worksheet, tmpSht As Worksheet
    Dim LastRow As Long, i As Long, j As Long

    '~~> Change Sheet1 to the sheet which has all the data
    Set ws = Sheets("Sheet1")

    With ws
        LastRow = .Range("A" & .Rows.Count).End(xlUp).Row

        If LastRow < 4 Then Exit Sub

        For i = 4 To LastRow
            If DoesSheetExist(.Range("A" & i).Value) Then
                Set tmpSht = Sheets(.Range("A" & i).Value)
            Else
                Sheets.Add After:=Sheets(Sheets.Count)
                Set tmpSht = ActiveSheet
                tmpSht.Name = .Range("A" & i).Value
            End If

            .Rows("1:3").Copy tmpSht.Rows(1)

            For j = 1 To 4
                tmpSht.Columns(j).ColumnWidth = .Columns(j).ColumnWidth
            Next j

            .Rows(i).Copy tmpSht.Rows(4)
        Next
    End With
End Sub

Function DoesSheetExist(Sht As String) As Boolean
    Dim ws As Worksheet

    On Error Resume Next
    Set ws = Sheets(ws)
    On Error GoTo 0

    If Not ws Is Nothing Then DoesSheetExist = True
End Function