Copy Header Row to Each Sheet

helpexcel

Well-known Member
Joined
Oct 21, 2009
Messages
656
I'm using this code to copy data from one workbook into another, with the data broken out onto separate sheets. The only thing that doesn't copy is Row 1, which has the headers. How do I copy that row onto each sheet?

Code:
Dim Lastrow As Long, LastCol As Integer, i As Long, iStart As Long, iEnd As LongDim ws As Worksheet, r As Range, iCol As Integer, t As Date, Prefix As String
Dim sh As Worksheet, Master As String, Folder As String, Fname As String
On Error Resume Next
Set r = Sheet23.Columns("N")
On Error GoTo 0
If r Is Nothing Then Exit Sub
iCol = r.Column
t = Now


With Sheet23
    Master = .Name
    Lastrow = .Cells(Rows.Count, "A").End(xlUp).Row
    LastCol = .Cells(1, Columns.Count).End(xlToLeft).Column
    .Range(.Cells(1, 1), .Cells(Lastrow, LastCol)).Sort Key1:=.Cells(1, iCol), Order1:=xlAscending, _
        Header:=xlYes, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
    iStart = 2
    For i = 2 To Lastrow
        If .Cells(i, iCol).Value <> .Cells(i + 1, iCol).Value Then
            iEnd = i
            Sheets.Add after:=Sheets(Sheets.Count)
            Set ws = ActiveSheet
            On Error Resume Next
            ws.Name = .Cells(iStart, iCol).Value
            On Error GoTo 0
             ws.Range(Cells(1, 1), Cells(1, LastCol)).Value = .Range(.Cells(1, 1), .Cells(1, LastCol)).Value
            .Range(.Cells(iStart, 1), .Cells(iEnd, LastCol)).Copy Destination:=ws.Range("A1")
            iStart = iEnd + 1
            Cells.Select
            Cells.EntireColumn.AutoFit
        End If
    Next i
End With
 

Excel Facts

Back into an answer in Excel
Use Data, What-If Analysis, Goal Seek to find the correct input cell value to reach a desired result
How about
Code:
    For i = 2 To Lastrow
        If .Cells(i, iCol).Value <> .Cells(i + 1, iCol).Value Then
            iEnd = i
            Set ws = Sheets.Add(, Sheets(Sheets.Count))
            On Error Resume Next
            ws.Name = .Cells(iStart, iCol).Value
            On Error GoTo 0
             ws.Range(ws.Cells(1, 1), ws.Cells(1, LastCol)).Value = .Range(.Cells(1, 1), .Cells(1, LastCol)).Value
            .Range(.Cells(iStart, 1), .Cells(iEnd, LastCol)).Copy Destination:=ws.Range("A2")
            iStart = iEnd + 1
            ws.Cells.EntireColumn.AutoFit
        End If
    Next i
 
Upvote 0
Thanks @Fluff, worked great. So even if you start the line with ws.Range, you need to continue the ws. throughout the procedure? It looks like that was the change that made the difference.
 
Upvote 0
That's right, otherwise it's looking at a mix of WS as the active sheet.
It's the same as you have done here
Code:
.Range(.Cells(1, 1), .Cells(1, LastCol)).Value
where you have qualified both the range & the cells
 
Upvote 0

Forum statistics

Threads
1,213,482
Messages
6,113,913
Members
448,532
Latest member
9Kimo3

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top