Hello All,

Anytime I run the second macro which consists of setting page margins and
full path to my reports; indeed, it does execute my request and displays the
following error message €œType mismatch.€� I usually click OK to ignore it. Is
there anyone who can assist me in getting rid of this error message?


Const FirstRowWithTeamData = 2 ' row 1 is header row
Const TeamColumn = "E" ' column with team ID/Sheet names
Const SourceSheet = "Summary Page"
Const FirstColToCopy = "A"
Const LastColToCopy = "V"
'change to = "A:A,B:B,C:C,D:D,I:I,J:J,L:L,M:M,N:N,O:O,P:P,Q:Q,R :R"

Const ColumnsToHide =
"A:A,B:B,C:C,D:D,I:I,J:J,L:L,M:M,N:N,O:O,P:P,Q:Q,R :R"

Dim lastDataRow As Long
Dim destSheet As String ' hold name of destination sheeet
Dim destRow As Long ' row on dest sheet to put data into
Dim rowOffset As Long ' pointer to data
Dim whatToCopy As Range
Dim wheretoPaste As Range
Dim testPageValue As Variant 'use to test for page presence
Dim tempRange As Range ' for use during new sheet insertions
Dim LC As Integer ' Loop Counter used in .AutoFit loop
Dim anySheet As Worksheet ' added for v3 use
Dim lastRow As Long ' added for v3 use

'find last used row on Summary Page
lastDataRow = Worksheets(SourceSheet).Range(TeamColumn &
Rows.Count).End(xlUp).Row
'select Summary Page and cell at top of team list
Worksheets(SourceSheet).Select
Range(TeamColumn & "1").Select
'turn off screen updating for speed
Application.ScreenUpdating = False
For rowOffset = (FirstRowWithTeamData - 1) To lastDataRow - 1
'don't do anything if cell is empty
If Not IsEmpty(ActiveCell.Offset(rowOffset, 0)) Then
' create name of sheet to seek
destSheet = Trim(ActiveCell.Offset(rowOffset, 0))
If Len(destSheet) 0 Then ' have a name!
Set whatToCopy =
Worksheets(SourceSheet).Range(ActiveSheet.Range(Fi rstColToCopy & rowOffset +
1).Address & ":" & ActiveSheet.Range(LastColToCopy & rowOffset + 1).Address)
'test if destination sheet exists
On Error Resume Next
' any cell will do
testPageValue = Worksheets(destSheet).Range("A1")
If Err < 0 Then
'page does not exist, create it
Err.Clear
On Error GoTo 0
Worksheets.Add ' add sheet, it gets selected
'can fail if destSheet is not a valid sheet name!
ActiveSheet.Name = destSheet ' name it
Cells.Select
With Selection.Font
.Name = "Times New Roman"
.Size = 10
End With
Range("A2").Select
ActiveWindow.FreezePanes = False

'added to move header info to new sheets
Set tempRange =
Worksheets(SourceSheet).Range(FirstColToCopy & "1:" & LastColToCopy & "1")
Set wheretoPaste =
Worksheets(destSheet).Range(FirstColToCopy & "1:" & LastColToCopy & "1")
wheretoPaste.Value = tempRange.Value
'set up font bold, centered and width of columns
wheretoPaste.Font.Bold = True
wheretoPaste.HorizontalAlignment = xlCenter
wheretoPaste.VerticalAlignment = xlCenter
Range(FirstColToCopy & "1:" & LastColToCopy & "1").Select
Selection.Columns.AutoFit
Range("A1").Select
Worksheets(SourceSheet).Select ' back to proper sheet
End If
On Error GoTo 0
destRow = Worksheets(destSheet).Range(TeamColumn &
Rows.Count).End(xlUp).Row
If Not (IsEmpty(Worksheets(destSheet).Range(TeamColumn &
destRow))) Then
'only on new, or empty sheets
destRow = destRow + 1
End If
Set wheretoPaste =
Worksheets(destSheet).Range(Range(FirstColToCopy & destRow).Address & ":" &
Range(LastColToCopy & destRow).Address)
wheretoPaste.Value = whatToCopy.Value
End If ' test for sheet name
End If ' test for empty cell
Next ' rowOffset loop

For Each anySheet In ThisWorkbook.Worksheets
If anySheet.Name < SourceSheet Then
lastRow = anySheet.Range("A1").End(xlDown).Row
anySheet.Rows("1:" & lastRow).Columns.AutoFit
anySheet.Rows("1:" & lastRow).Rows.AutoFit
anySheet.Range("P1").ColumnWidth = 10

With anySheet.Range("A1:V" & lastRow)
.Borders(xlDiagonalDown).LineStyle = xlNone
.Borders(xlDiagonalUp).LineStyle = xlNone
With .Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With .Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With .Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With .Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With .Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With .Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
End With
anySheet.Range(ColumnsToHide).EntireColumn.Hidden = True
End If
Next
Worksheets(SourceSheet).Select
Application.ScreenUpdating = True
End Sub










----------------------------------------------------------------------------------

Public Sub PageSet()
Dim ws As Worksheet
For Each ws In ActiveWorkbook.Sheets
With ws.PageSetup
.Orientation = xlLandscape
.LeftMargin = Application.InchesToPoints(0.38)
.RightMargin = Application.InchesToPoints(0.39)
.TopMargin = Application.InchesToPoints(1)
.BottomMargin = Application.InchesToPoints(1)
.HeaderMargin = Application.InchesToPoints(0.5)
.FooterMargin = Application.InchesToPoints(0.5)


.PaperSize = xlPaperLegal

.FirstPageNumber = xlAutomatic
.CenterHeader = " "
.PrintErrors = xlPrintErrorsDisplayed
End With
Next ws
End Sub

__________________________________________________ _________

Public Sub DoFullPath()
Dim ws As Worksheet
For Each ws In ActiveWorkbook.Sheets
With ws.PageSetup
' .CenterHeader = ActiveWorkbook.Name & _
'vbLf & ActiveSheet.Name

.CenterHeader = ActiveWorkbook.Name & _
vbLf & ws.Name

'ActiveSheet.PageSetup.CenterHeader = ActiveWorkbook.Name & _
vbLf & ActiveSheet.Name
End With
Next ws


Thanks,

I ran the last two macro without any errors.

Have you stepped through the code????

click on this line of code
For Each ws In ActiveWorkbook.Sheets


Then press F9 to add break point
TheN press F5 to run code
Then press F8 to step through code until error occurs.


"Jurassien" wrote:


Hello All,

Anytime I run the second macro which consists of setting page margins and
full path to my reports; indeed, it does execute my request and displays the
following error message €œType mismatch.€� I usually click OK to ignore it. Is
there anyone who can assist me in getting rid of this error message?


Const FirstRowWithTeamData = 2 ' row 1 is header row
Const TeamColumn = "E" ' column with team ID/Sheet names
Const SourceSheet = "Summary Page"
Const FirstColToCopy = "A"
Const LastColToCopy = "V"
'change to = "A:A,B:B,C:C,D:D,I:I,J:J,L:L,M:M,N:N,O:O,P:P,Q:Q,R :R"

Const ColumnsToHide =
"A:A,B:B,C:C,D:D,I:I,J:J,L:L,M:M,N:N,O:O,P:P,Q:Q,R :R"

Dim lastDataRow As Long
Dim destSheet As String ' hold name of destination sheeet
Dim destRow As Long ' row on dest sheet to put data into
Dim rowOffset As Long ' pointer to data
Dim whatToCopy As Range
Dim wheretoPaste As Range
Dim testPageValue As Variant 'use to test for page presence
Dim tempRange As Range ' for use during new sheet insertions
Dim LC As Integer ' Loop Counter used in .AutoFit loop
Dim anySheet As Worksheet ' added for v3 use
Dim lastRow As Long ' added for v3 use

'find last used row on Summary Page
lastDataRow = Worksheets(SourceSheet).Range(TeamColumn &
Rows.Count).End(xlUp).Row
'select Summary Page and cell at top of team list
Worksheets(SourceSheet).Select
Range(TeamColumn & "1").Select
'turn off screen updating for speed
Application.ScreenUpdating = False
For rowOffset = (FirstRowWithTeamData - 1) To lastDataRow - 1
'don't do anything if cell is empty
If Not IsEmpty(ActiveCell.Offset(rowOffset, 0)) Then
' create name of sheet to seek
destSheet = Trim(ActiveCell.Offset(rowOffset, 0))
If Len(destSheet) 0 Then ' have a name!
Set whatToCopy =
Worksheets(SourceSheet).Range(ActiveSheet.Range(Fi rstColToCopy & rowOffset +
1).Address & ":" & ActiveSheet.Range(LastColToCopy & rowOffset + 1).Address)
'test if destination sheet exists
On Error Resume Next
' any cell will do
testPageValue = Worksheets(destSheet).Range("A1")
If Err < 0 Then
'page does not exist, create it
Err.Clear
On Error GoTo 0
Worksheets.Add ' add sheet, it gets selected
'can fail if destSheet is not a valid sheet name!
ActiveSheet.Name = destSheet ' name it
Cells.Select
With Selection.Font
.Name = "Times New Roman"
.Size = 10
End With
Range("A2").Select
ActiveWindow.FreezePanes = False

'added to move header info to new sheets
Set tempRange =
Worksheets(SourceSheet).Range(FirstColToCopy & "1:" & LastColToCopy & "1")
Set wheretoPaste =
Worksheets(destSheet).Range(FirstColToCopy & "1:" & LastColToCopy & "1")
wheretoPaste.Value = tempRange.Value
'set up font bold, centered and width of columns
wheretoPaste.Font.Bold = True
wheretoPaste.HorizontalAlignment = xlCenter
wheretoPaste.VerticalAlignment = xlCenter
Range(FirstColToCopy & "1:" & LastColToCopy & "1").Select
Selection.Columns.AutoFit
Range("A1").Select
Worksheets(SourceSheet).Select ' back to proper sheet
End If
On Error GoTo 0
destRow = Worksheets(destSheet).Range(TeamColumn &
Rows.Count).End(xlUp).Row
If Not (IsEmpty(Worksheets(destSheet).Range(TeamColumn &
destRow))) Then
'only on new, or empty sheets
destRow = destRow + 1
End If
Set wheretoPaste =
Worksheets(destSheet).Range(Range(FirstColToCopy & destRow).Address & ":" &
Range(LastColToCopy & destRow).Address)
wheretoPaste.Value = whatToCopy.Value
End If ' test for sheet name
End If ' test for empty cell
Next ' rowOffset loop

For Each anySheet In ThisWorkbook.Worksheets
If anySheet.Name < SourceSheet Then
lastRow = anySheet.Range("A1").End(xlDown).Row
anySheet.Rows("1:" & lastRow).Columns.AutoFit
anySheet.Rows("1:" & lastRow).Rows.AutoFit
anySheet.Range("P1").ColumnWidth = 10

With anySheet.Range("A1:V" & lastRow)
.Borders(xlDiagonalDown).LineStyle = xlNone
.Borders(xlDiagonalUp).LineStyle = xlNone
With .Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With .Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With .Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With .Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With .Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With .Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
End With
anySheet.Range(ColumnsToHide).EntireColumn.Hidden = True
End If
Next
Worksheets(SourceSheet).Select
Application.ScreenUpdating = True
End Sub










----------------------------------------------------------------------------------

Public Sub PageSet()
Dim ws As Worksheet
For Each ws In ActiveWorkbook.Sheets
With ws.PageSetup
.Orientation = xlLandscape
.LeftMargin = Application.InchesToPoints(0.38)
.RightMargin = Application.InchesToPoints(0.39)
.TopMargin = Application.InchesToPoints(1)
.BottomMargin = Application.InchesToPoints(1)
.HeaderMargin = Application.InchesToPoints(0.5)
.FooterMargin = Application.InchesToPoints(0.5)


.PaperSize = xlPaperLegal

.FirstPageNumber = xlAutomatic
.CenterHeader = " "
.PrintErrors = xlPrintErrorsDisplayed
End With
Next ws
End Sub

__________________________________________________ _________

Public Sub DoFullPath()
Dim ws As Worksheet
For Each ws In ActiveWorkbook.Sheets
With ws.PageSetup
' .CenterHeader = ActiveWorkbook.Name & _
'vbLf & ActiveSheet.Name

.CenterHeader = ActiveWorkbook.Name & _
vbLf & ws.Name

'ActiveSheet.PageSetup.CenterHeader = ActiveWorkbook.Name & _
vbLf & ActiveSheet.Name
End With
Next ws


Thanks,