Carry same Header to all new sheets

[D3allamerican07]

I have created a code to create a new sheet for every unique value in column A. I'm looking for every time it creates a new sheet, it also brings the same header in Row 1 with it (there are 13 different cells for row 1, A:M)

This is the code I have so far:

Sub Test()
Dim i As Integer
Dim l As Integer
Dim i2 As Integer
Dim l2 As Integer

Dim maxIt As Integer
maxIt = 10 'Set max length of main sheet

Dim mainSheet As String
mainSheet = "Sheet1" 'Set main sheet name

Dim lastColumn As String
lastColumn = "M" 'Set last column of main sheet

Dim exitString As String
exitString = "" 'If you want to end on a specific value in column A

Sheets(mainSheet).Activate
For i = 1 To maxIt
If Sheets(mainSheet).Range("$A$" & i).Value = exitString Then
l = i - 1
Exit For
End If
Next i

For i = 1 To l
Sheets(mainSheet).Range("A" & i & ":" & lastColumn & i).Select
Selection.Copy
On Error Resume Next
Sheets(Sheets(mainSheet).Range("A" & i).Value).Activate
If ActiveSheet.Name <> Sheets(mainSheet).Range("A" & i).Value Then
Sheets.Add After:=Worksheets(Worksheets.Count)
ActiveSheet.Name = Sheets(mainSheet).Range("A" & i).Value
End If


For i2 = 1 To maxIt
If ActiveSheet.Range("$A$" & i2).Value = "" Then
l2 = i2
Exit For
End If
Next i2
ActiveSheet.Range("$A$" & i2).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets(mainSheet).Select
Application.CutCopyMode = False
Next i
Sheets(mainSheet).Activate
ActiveSheet.Range("$A$1").Select

End Sub[/B]

 

[igold]

Hi,

As I read your very first line in your post:

I'm looking for every time it creates a new sheet, it also brings the same header in Row 1 with it (there are 13 different cells for row 1, A:M)

This code will do that for you. However as I read the code you wrote you have a lot of other stuff thrown in there which is not addressed here.

This code assumes that Sheet1 is your sheet with the sheet names and header row that you want copied. This code should go into a module. Please test code on a backup copy of your data.

Sub test()

    Dim ws1 As Worksheet: Set ws1 = Worksheets("Sheet1")
    Dim strSearch As Range
    Dim lRow As Long
    Dim shtName As String
    Dim WS As Worksheet
    Dim i As Long, x As Long

    lRow = ws1.Cells(Rows.Count, 1).End(xlUp).Row
    For i = 1 To lRow
        ws1.Activate
        shtName = ws1.Cells(i + 1, 1).Value
        Set strSearch = Range("A1:A" & lRow).Find(what:=shtName)
            If Not strSearch Is Nothing Then
                For x = 1 To Worksheets.Count
                    If Worksheets(x).Name = shtName Then GoTo Next1
                Next
            Set WS = Sheets.Add(after:=Worksheets(Worksheets.Count))
            WS.Name = shtName
            ws1.Range("A1:M1").Copy Worksheets(shtName).Range("A1")
         End If
Next1:
    Next
End Sub

HTH

igold