Code to split worksheet into multiple sheets and keep multi line header on each

PatrickSchmidt

New Member
Joined
Apr 30, 2014
Messages
25

Hello I found the code below online. It works great parsing out the data to individual sheets but I can't get it to copy more than 1 header row. I have instructions in cells in rows 1 through 9 I would like copied to every new sheet. I have changed title = (1:1) to title = "1:10" and title = "A1:L1" and many other combinations but I cannot get it to copy anything above row 10. Please help.
Below is my code and representation of my data.

Thank you very much



Sub PDFs()

Dim lr As Long
Dim ws As Worksheet
Dim vcol, i As Integer
Dim icol As Long
Dim myarr As Variant
Dim title As String
Dim titlerow As Integer
Dim today As String
today = Format(Date, "yyyy mm-dd")
Workbooks.Open "C:\Appointments\Appointments.xls"
Windows("Next_Day_Appointments.xls").Activate
vcol = 9
Set ws = Sheets("Next Day Appointments")
lr = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row
title = "1:1" '-------------------------------------here I have tried title = "1:10" and title = "A1:L1"
titlerow = ws.Range(title).Cells(1).Row
icol = ws.Columns.Count
ws.Cells(1, icol) = "Unique"
For i = 2 To lr
On Error Resume Next
If ws.Cells(i, vcol) <> "" And Application.WorksheetFunction.Match(ws.Cells(i, vcol), ws.Columns(icol), 0) = 0 Then
ws.Cells(ws.Rows.Count, icol).End(xlUp).Offset(1) = ws.Cells(i, vcol)
End If
Next
myarr = Application.WorksheetFunction.Transpose(ws.Columns(icol).SpecialCells(xlCellTypeConstants))
ws.Columns(icol).Clear
For i = 2 To UBound(myarr)
ws.Range(title).AutoFilter field:=vcol, Criteria1:=myarr(i) & ""
If Not Evaluate("=ISREF('" & myarr(i) & "'!A1)") Then
Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = myarr(i) & ""
Else
Sheets(myarr(i) & "").Move after:=Worksheets(Worksheets.Count)
End If
ws.Range("A" & titlerow & ":A" & lr).EntireRow.Copy Sheets(myarr(i) & "").Range("A1")
Sheets(myarr(i) & "").Columns.AutoFit
Next
ws.AutoFilterMode = False
ws.Activate


Application.DisplayAlerts = False
ActiveWorkbook.SaveAs "C:\Temp\" & today & ".xls"


Dim Fname As String
For Each ws In ActiveWorkbook.Worksheets
On Error Resume Next

Fname = "C:\Temp\" & ws.Name

ws.ExportAsFixedFormat _
Type:=xlTypePDF, _
Filename:=Fname, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False

Next ws

Application.DisplayAlerts = True

End Sub



[TABLE="class: grid, width: 768"]
<tbody>[TR]
[TD][/TD]
[TD="width: 64"][/TD]
[TD="width: 64"][/TD]
[TD="width: 64"][/TD]
[TD="width: 64"][/TD]
[TD="width: 64"][/TD]
[TD="width: 64"][/TD]
[TD="width: 64"][/TD]
[TD="width: 64"][/TD]
[TD="width: 64"][/TD]
[TD="width: 64"][/TD]
[TD="width: 64"][/TD]
[/TR]
[TR]
[TD]Blah[/TD]
[TD]Blah[/TD]
[TD]Blah[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Blah[/TD]
[TD]Blah[/TD]
[TD]Blah[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Blah[/TD]
[TD]Blah[/TD]
[TD]Blah[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Blah[/TD]
[TD]Blah[/TD]
[TD]Blah[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Blah[/TD]
[TD]Blah[/TD]
[TD]Blah[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Blah[/TD]
[TD]Blah[/TD]
[TD]Blah[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Blah[/TD]
[TD]Blah[/TD]
[TD]Blah[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Header1[/TD]
[TD]Header2[/TD]
[TD]Header3[/TD]
[TD]Header4[/TD]
[TD]Header5[/TD]
[TD]Header6[/TD]
[TD]Header7[/TD]
[TD]Header8[/TD]
[TD]Header9[/TD]
[TD]Header10[/TD]
[TD]Header11[/TD]
[TD]Header12[/TD]
[/TR]
[TR]
[TD="align: right"]1[/TD]
[TD="align: right"]1[/TD]
[TD="align: right"]1[/TD]
[TD="align: right"]1[/TD]
[TD="align: right"]1[/TD]
[TD="align: right"]1[/TD]
[TD="align: right"]1[/TD]
[TD="align: right"]1[/TD]
[TD]Name1[/TD]
[TD="align: right"]1[/TD]
[TD="align: right"]1[/TD]
[TD="align: right"]1[/TD]
[/TR]
[TR]
[TD="align: right"]2[/TD]
[TD="align: right"]2[/TD]
[TD="align: right"]2[/TD]
[TD="align: right"]2[/TD]
[TD="align: right"]2[/TD]
[TD="align: right"]2[/TD]
[TD="align: right"]2[/TD]
[TD="align: right"]2[/TD]
[TD]Name2[/TD]
[TD="align: right"]2[/TD]
[TD="align: right"]2[/TD]
[TD="align: right"]2[/TD]
[/TR]
[TR]
[TD="align: right"]3[/TD]
[TD="align: right"]3[/TD]
[TD="align: right"]3[/TD]
[TD="align: right"]3[/TD]
[TD="align: right"]3[/TD]
[TD="align: right"]3[/TD]
[TD="align: right"]3[/TD]
[TD="align: right"]3[/TD]
[TD]Name3[/TD]
[TD="align: right"]3[/TD]
[TD="align: right"]3[/TD]
[TD="align: right"]3[/TD]
[/TR]
[TR]
[TD="align: right"]4[/TD]
[TD="align: right"]4[/TD]
[TD="align: right"]4[/TD]
[TD="align: right"]4[/TD]
[TD="align: right"]4[/TD]
[TD="align: right"]4[/TD]
[TD="align: right"]4[/TD]
[TD="align: right"]4[/TD]
[TD]Name4[/TD]
[TD="align: right"]4[/TD]
[TD="align: right"]4[/TD]
[TD="align: right"]4[/TD]
[/TR]
[TR]
[TD="align: right"]5[/TD]
[TD="align: right"]5[/TD]
[TD="align: right"]5[/TD]
[TD="align: right"]5[/TD]
[TD="align: right"]5[/TD]
[TD="align: right"]5[/TD]
[TD="align: right"]5[/TD]
[TD="align: right"]5[/TD]
[TD]Name5[/TD]
[TD="align: right"]5[/TD]
[TD="align: right"]5[/TD]
[TD="align: right"]5[/TD]
[/TR]
[TR]
[TD="align: right"]6[/TD]
[TD="align: right"]6[/TD]
[TD="align: right"]6[/TD]
[TD="align: right"]6[/TD]
[TD="align: right"]6[/TD]
[TD="align: right"]6[/TD]
[TD="align: right"]6[/TD]
[TD="align: right"]6[/TD]
[TD]Name6[/TD]
[TD="align: right"]6[/TD]
[TD="align: right"]6[/TD]
[TD="align: right"]6[/TD]
[/TR]
[TR]
[TD="align: right"]7[/TD]
[TD="align: right"]7[/TD]
[TD="align: right"]7[/TD]
[TD="align: right"]7[/TD]
[TD="align: right"]7[/TD]
[TD="align: right"]7[/TD]
[TD="align: right"]7[/TD]
[TD="align: right"]7[/TD]
[TD]Name7[/TD]
[TD="align: right"]7[/TD]
[TD="align: right"]7[/TD]
[TD="align: right"]7[/TD]
[/TR]
[TR]
[TD="align: right"]8[/TD]
[TD="align: right"]8[/TD]
[TD="align: right"]8[/TD]
[TD="align: right"]8[/TD]
[TD="align: right"]8[/TD]
[TD="align: right"]8[/TD]
[TD="align: right"]8[/TD]
[TD="align: right"]8[/TD]
[TD]Name8[/TD]
[TD="align: right"]8[/TD]
[TD="align: right"]8[/TD]
[TD="align: right"]8[/TD]
[/TR]
[TR]
[TD="align: right"]9[/TD]
[TD="align: right"]9[/TD]
[TD="align: right"]9[/TD]
[TD="align: right"]9[/TD]
[TD="align: right"]9[/TD]
[TD="align: right"]9[/TD]
[TD="align: right"]9[/TD]
[TD="align: right"]9[/TD]
[TD]Name9[/TD]
[TD="align: right"]9[/TD]
[TD="align: right"]9[/TD]
[TD="align: right"]9[/TD]
[/TR]
[TR]
[TD="align: right"]10[/TD]
[TD="align: right"]10[/TD]
[TD="align: right"]10[/TD]
[TD="align: right"]10[/TD]
[TD="align: right"]10[/TD]
[TD="align: right"]10[/TD]
[TD="align: right"]10[/TD]
[TD="align: right"]10[/TD]
[TD]Name10[/TD]
[TD="align: right"]10[/TD]
[TD="align: right"]10[/TD]
[TD="align: right"]10[/TD]
[/TR]
</tbody>[/TABLE]
 
Last edited:

Excel Facts

When they said...
When they said you are going to "Excel at life", they meant you "will be doing Excel your whole life".
Hello,

does this work as expected?

Code:
Sub PDFs()

Dim lr As Long
Dim ws As Worksheet
Dim vcol, i As Integer
Dim icol As Long
Dim myarr As Variant
Dim title As String
Dim titlerow As Integer
Dim today As String
today = Format(Date, "yyyy mm-dd")
Workbooks.Open "C:\Appointments\Appointments.xls"
Windows("Next_Day_Appointments.xls").Activate
vcol = 9
Set ws = Sheets("Next Day Appointments")
lr = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row
title = "1:1" '-------------------------------------here I have tried title = "1:10" and title = "A1:L1"
titlefilter = "8:8"
titlerow = ws.Range(title).Cells(1).Row
icol = ws.Columns.Count
ws.Cells(1, icol) = "Unique"
For i = 9 To lr
On Error Resume Next
If ws.Cells(i, vcol) <> "" And Application.WorksheetFunction.Match(ws.Cells(i, vcol), ws.Columns(icol), 0) = 0 Then
ws.Cells(ws.Rows.Count, icol).End(xlUp).Offset(1) = ws.Cells(i, vcol)
End If
Next
myarr = Application.WorksheetFunction.Transpose(ws.Columns(icol).SpecialCells(xlCellTypeConstants))
ws.Columns(icol).Clear
For i = 2 To UBound(myarr)
ws.Range(titlefilter).AutoFilter field:=vcol, Criteria1:=myarr(i) & ""
If Not Evaluate("=ISREF('" & myarr(i) & "'!A1)") Then
Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = myarr(i) & ""
Else
Sheets(myarr(i) & "").Move after:=Worksheets(Worksheets.Count)
End If
ws.Range("A" & titlerow & ":A" & lr).EntireRow.Copy Sheets(myarr(i) & "").Range("A1")
Sheets(myarr(i) & "").Columns.AutoFit
Next
ws.AutoFilterMode = False
ws.Activate


Application.DisplayAlerts = False
ActiveWorkbook.SaveAs "C:\Temp\" & today & ".xls"


Dim Fname As String
For Each ws In ActiveWorkbook.Worksheets
On Error Resume Next

Fname = "C:\Temp\" & ws.Name

ws.ExportAsFixedFormat _
Type:=xlTypePDF, _
Filename:=Fname, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False

Next ws

Application.DisplayAlerts = True

End Sub

have only tried it without opening another workbook, and up to the save as.
 
Upvote 0
Hello,

does this work as expected?

Code:
Sub PDFs()

Dim lr As Long
Dim ws As Worksheet
Dim vcol, i As Integer
Dim icol As Long
Dim myarr As Variant
Dim title As String
Dim titlerow As Integer
Dim today As String
today = Format(Date, "yyyy mm-dd")
Workbooks.Open "C:\Appointments\Appointments.xls"
Windows("Next_Day_Appointments.xls").Activate
vcol = 9
Set ws = Sheets("Next Day Appointments")
lr = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row
title = "1:1" '-------------------------------------here I have tried title = "1:10" and title = "A1:L1"
titlefilter = "8:8"
titlerow = ws.Range(title).Cells(1).Row
icol = ws.Columns.Count
ws.Cells(1, icol) = "Unique"
For i = 9 To lr
On Error Resume Next
If ws.Cells(i, vcol) <> "" And Application.WorksheetFunction.Match(ws.Cells(i, vcol), ws.Columns(icol), 0) = 0 Then
ws.Cells(ws.Rows.Count, icol).End(xlUp).Offset(1) = ws.Cells(i, vcol)
End If
Next
myarr = Application.WorksheetFunction.Transpose(ws.Columns(icol).SpecialCells(xlCellTypeConstants))
ws.Columns(icol).Clear
For i = 2 To UBound(myarr)
ws.Range(titlefilter).AutoFilter field:=vcol, Criteria1:=myarr(i) & ""
If Not Evaluate("=ISREF('" & myarr(i) & "'!A1)") Then
Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = myarr(i) & ""
Else
Sheets(myarr(i) & "").Move after:=Worksheets(Worksheets.Count)
End If
ws.Range("A" & titlerow & ":A" & lr).EntireRow.Copy Sheets(myarr(i) & "").Range("A1")
Sheets(myarr(i) & "").Columns.AutoFit
Next
ws.AutoFilterMode = False
ws.Activate


Application.DisplayAlerts = False
ActiveWorkbook.SaveAs "C:\Temp\" & today & ".xls"


Dim Fname As String
For Each ws In ActiveWorkbook.Worksheets
On Error Resume Next

Fname = "C:\Temp\" & ws.Name

ws.ExportAsFixedFormat _
Type:=xlTypePDF, _
Filename:=Fname, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False

Next ws

Application.DisplayAlerts = True

End Sub

have only tried it without opening another workbook, and up to the save as.


It works. Thank you!!
I see you added titlefilter = "8:8"
Can you explain to me what that did/how it worked?
Again thank you very much!
 
Upvote 0

Forum statistics

Threads
1,223,098
Messages
6,170,099
Members
452,301
Latest member
QualityAssurance

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