All,
I have a working macro that splits out invoice lines to separate tabs and I have formatting set. I am attempting to add code for the print area. I found a working suggestion online but don't know how to incorporate within this macro so that all tabs have this page setup. Can someone assist? Thanks in advance
Code to Add
Sub AreaPrint ()
Dim Sheet1 As Worksheet
Set Sheet1 = ActiveWorkbook.Worksheets(1)
With Sheet1.PageSetup
.Zoom = False
.Orientation = xlLandscape
.FitToPagesWide = 1
.FitToPagesTall = False
.PrintTitleRows = “$A$1:$Y$1”
End With
End Sub
Current Macro
Sub Test()
Dim wRow As Long ' row counter
Dim wCol As Integer ' column counter
Dim wSheetName As String ' name of sheet that we will create to move data to
Dim wDataSheetName As String ' name of sheet that has new data
Dim wFirstRow As Long ' used to store first row of move
Dim wLastInvRow As Long ' used to find last row of current invoice
Dim wLastRow As Long ' used to store last row of move
wDataSheetName = ActiveSheet.Name
Dim myloop
For myloop = Range("D65536").End(xlUp).Row To 1 Step -1
If Cells(myloop, 11).Value = 0 Then Rows(myloop).EntireRow.Delete
Next myloop
Cells.Select
Cells.EntireColumn.autofit
With Selection.Font
.Name = "Arial Narrow"
.Size = 10
Rows("1:10000").RowHeight = 15
Columns("K:L").Select
Selection.Style = "Comma"
wSheetName = Range("A2")
If wSheetName <> "" Then
Range("A1").Select
wLastRow = 2
Do
wLastRow = wLastRow + 1
Loop Until Cells(wLastRow, 1) = "" And Cells(wLastRow + 1, 1) = ""
ActiveWorkbook.Worksheets(wDataSheetName).Sort.SortFields.Clear
ActiveWorkbook.Worksheets(wDataSheetName).Sort.SortFields.Add Key:=Range("A2:A4425"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
ActiveWorkbook.Worksheets(wDataSheetName).Sort.SortFields.Add Key:=Range("J2:J4425"), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets(wDataSheetName).Sort
.SetRange Range("A2:Y" & Trim(Str(wLastRow - 1)))
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End If
Do While Range("A2") <> ""
If wSheetName = "" Then wSheetName = Range("A2") ' get new sheet name if not present
Sheets.Add
On Error Resume Next
NameSheet:
ActiveSheet.Name = wSheetName
If Err = 1004 Then ' duplicate sheet name found
On Error GoTo NameSheet
wSheetName = InputBox("Duplicate sheet name found!" & vbCrLf & vbCrLf & _
"What name do you want to give it?", "SHEET NAME DUPLICATE", wSheetName & "(1)")
ActiveSheet.Name = wSheetName
If Err = 0 Then
On Error GoTo 0 ' turn off error handling
End If
End If
Application.Goto reference:=Sheets(wDataSheetName).Range("A2")
wFirstRow = 2
wLastInvRow = 2
Do
wLastInvRow = wLastInvRow + 1
Loop Until Cells(wLastInvRow, 1) <> Cells(wLastInvRow - 1, 1)
wLastInvRow = wLastinvRow - 1
Range("A1:Y" & Trim(Str(wLastInvRow))).Select
Selection.Copy Destination:=Sheets(wSheetName).Range("A1")
Range("A2:Y" & Trim(Str(wLastInvRow))).EntireRow.Delete
Range("A2").Select
Application.Goto reference:=Sheets(wSheetName).Range("A1")
Range("A1:Y" & Trim(Str(wLastInvRow))).Select
Selection.Subtotal GroupBy:=10, Function:=xlSum, TotalList:=Array(11, 12), Replace:=True, PageBreaks:=False, SummaryBelowData:=True
Range("A1:A" & Trim(Str(wLastInvRow + 99))).Select
Selection.Rows.Ungroup
Selection.Rows.Ungroup
Range("A:Y").Columns.AutoFit
Range("A1").Select 'return to top left cell
Application.Goto reference:=Sheets(wDataSheetName).Range("A2")
wSheetName = "" ' clear sheet name for next pass
Loop
End With
End Sub
Bookmarks