Print area and borders macro based on cells contents

**jsantos** · 10-20-2012, 01:52 PM

Hi Guys

I am trying to get a few things together in the same macro, i have most of it but it's messy when i put it together and doesn't quite work.
My intention was to clear print area, have the first 2 rows printed in all sheets if more than 1, have a center foot with page No of, in landscape printed in greyscale.

    Application.ScreenUpdating = False
    
    Dim ws As Worksheet
    For Each ws In ActiveWorkbook.Sheets
        With ws.PageSetup
            .PrintArea = ""
            .PrintTitleRows = "$1:$2"
            .CenterFooter = "Page &P of &N"
            .CenterVertically = False
            .PrintHeadings = False
            .Orientation = xlLandscape
            .FirstPageNumber = xlAutomatic
            .BlackAndWhite = True
        End With
    Next ws
    
    Application.ScreenUpdating = True

Then set the print area based on the last cell with value,

Sub find_print_area()
        Dim ws As Worksheet
    For Each ws In ActiveWorkbook.Sheets
        With ws.PageSetup.Activate
Dim x As Long, lastCell As Range
x = ActiveSheet.UsedRange.Columns.Count
Set lastCell = Cells.SpecialCells(xlCellTypeLastCell)
ActiveSheet.PageSetup.PrintArea = Range(Cells(1, 1), lastCell).Address
End Sub
    
    End Sub

then to finish add a thick border around the "print area" area with a hairline border on the inside.

Sub Bordersup()
'
' Bordersup Macro
'

        Dim ws As Worksheet
    For Each ws In ActiveWorkbook.Sheets
        With ws.PageSetup.Activate
    Range(Cells(1, 1), lastCell).Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .Weight = xlHairline
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .Weight = xlHairline
    End With
    Range("J20").Select
End Sub

Any help will be really apreciated.

Regards
Jsantos

**JBeaucaire** · 10-20-2012, 02:41 PM

Try this:

Option Explicit

Sub FormatPrintAreas()
Dim ws As Worksheet, LR As Long, LC As Long

Application.ScreenUpdating = False

    For Each ws In ActiveWorkbook.Sheets
        With ws
            LR = .Cells.Find("*", .Cells(.Rows.Count, .Columns.Count), _
                SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
            LC = .Cells.Find("*", .Cells(.Rows.Count, .Columns.Count), _
                SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column

            With .PageSetup
                .PrintArea = .Range("A1", .Cells(LR, LC)).Address
                .PrintTitleRows = "$1:$2"
                .CenterFooter = "Page &P of &N"
                .CenterVertically = False
                .PrintHeadings = False
                .Orientation = xlLandscape
                .FirstPageNumber = xlAutomatic
                .BlackAndWhite = True
            End With

            With .Range("A1", .Cells(LR, LC))
                .Borders(xlDiagonalDown).LineStyle = xlNone
                .Borders(xlDiagonalUp).LineStyle = xlNone
                .Borders(xlEdgeLeft).Weight = xlMedium
                .Borders(xlEdgeTop).Weight = xlMedium
                .Borders(xlEdgeBottom).Weight = xlMedium
                .Borders(xlEdgeRight).Weight = xlMedium
                .Borders(xlInsideVertical).Weight = xlHairline
                .Borders(xlInsideHorizontal).Weight = xlHairline
            End With
        End With
    Next ws

    Application.ScreenUpdating = True
End Sub

**jsantos** · 10-20-2012, 04:41 PM

Hi JBeaucaire

Thanks it looks a lot tidier, unfortunatly when i try to run it an error message comes up "Object doesn't support this property or method".
It's not like i use excell everyday but it's the first time i see this error.

Can you help

Many thanks
Jsantos

**JBeaucaire** · 10-21-2012, 02:36 AM

Try this change:

                .PrintArea = "" & Range("A1", Cells(LR, LC)).Address & ""

**jsantos** · 10-21-2012, 07:51 AM

Hi JBeaucaire
Made the change as you sgested and it now runs for about 4 seconds to then give me error "400"
At first it was giving me far more pages than i expected, but manage to find out that the sheets i was using initially had borders that would make the print area go to the 50 plus pages. I corrected this but can't see the reason for this error code come up.
As far as i can see everything i wanted gets done.

Many thanks for your pacience and help

Jsantos

**jsantos** · 10-21-2012, 05:28 PM

Hi JBeaucaire
The reason for the error was because one of the sheets was protected.
One last question:
Would it be possible to stop the above macro to apply to one sheet in the workbook? In this case the sheet would always have the same name ("Header")?

Many thanks
Jsantos

**JBeaucaire** · 10-22-2012, 02:28 AM

This is for the one sheet only:

Option Explicit

Sub FormatPrintAreas()
Dim ws As Worksheet, LR As Long, LC As Long

Application.ScreenUpdating = False

        With Sheets("Header")
            LR = .Cells.Find("*", .Cells(.Rows.Count, .Columns.Count), _
                SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
            LC = .Cells.Find("*", .Cells(.Rows.Count, .Columns.Count), _
                SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column

            With .PageSetup
                .PrintArea = .Range("A1", .Cells(LR, LC)).Address
                .PrintTitleRows = "$1:$2"
                .CenterFooter = "Page &P of &N"
                .CenterVertically = False
                .PrintHeadings = False
                .Orientation = xlLandscape
                .FirstPageNumber = xlAutomatic
                .BlackAndWhite = True
            End With

            With .Range("A1", .Cells(LR, LC))
                .Borders(xlDiagonalDown).LineStyle = xlNone
                .Borders(xlDiagonalUp).LineStyle = xlNone
                .Borders(xlEdgeLeft).Weight = xlMedium
                .Borders(xlEdgeTop).Weight = xlMedium
                .Borders(xlEdgeBottom).Weight = xlMedium
                .Borders(xlEdgeRight).Weight = xlMedium
                .Borders(xlInsideVertical).Weight = xlHairline
                .Borders(xlInsideHorizontal).Weight = xlHairline
            End With
        End With

    Application.ScreenUpdating = True
End Sub

**jsantos** · 10-22-2012, 06:14 AM

Hi JBeaucaire

Your change will make the macro run just for that particular sheet, what i want is to have the macro applying my instructions to all the sheets but the "Header" sheet.
My workaround is as follows, just tought there would be something that would stop the macro running on that sheet.
It takes quite a while to run this macro thats why i was thinking about a way to remove this sheet from it.

Regards
Joaquim

Sub FormatPrintAreas()
Dim ws As Worksheet, LR As Long, LC As Long
Sheets("HEADER").Unprotect
Application.ScreenUpdating = False

    For Each ws In ActiveWorkbook.Sheets
        With ws
            LR = .Cells.Find("*", .Cells(.Rows.Count, .Columns.Count), _
                SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
            LC = .Cells.Find("*", .Cells(.Rows.Count, .Columns.Count), _
                SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column

            With .PageSetup
                .PrintArea = "" & Range("A1", Cells(LR, LC)).Address & ""
            '.PrintArea = .Range("A1", .Cells(LR, LC)).Address
                .PrintTitleRows = "$1:$2"
                .CenterFooter = "Page &P of &N"
                .CenterVertically = False
                .PrintHeadings = False
                .Orientation = xlLandscape
                .FirstPageNumber = xlAutomatic
                .BlackAndWhite = True
            End With

            With .Range("A1", .Cells(LR, LC))
                .Borders(xlDiagonalDown).LineStyle = xlNone
                .Borders(xlDiagonalUp).LineStyle = xlNone
                .Borders(xlEdgeLeft).Weight = xlMedium
                .Borders(xlEdgeTop).Weight = xlMedium
                .Borders(xlEdgeBottom).Weight = xlMedium
                .Borders(xlEdgeRight).Weight = xlMedium
                .Borders(xlInsideVertical).Weight = xlHairline
                .Borders(xlInsideHorizontal).Weight = xlHairline
            End With
             Sheets("HEADER").Cells.Borders.LineStyle = xlNone
        End With
        Sheets("HEADER").Range("i20").Select
    Next ws

    Application.ScreenUpdating = True
  Sheets("HEADER").Protect DrawingObjects:=False, Contents:=True, Scenarios:=False
End Sub

**JBeaucaire** · 10-22-2012, 03:10 PM

Option Explicit

Sub FormatPrintAreas()
Dim ws As Worksheet, LR As Long, LC As Long

Application.ScreenUpdating = False

    For Each ws In ActiveWorkbook.Sheets
        If UCase(ws.Name) <> "HEADER" Then
          With ws
            LR = .Cells.Find("*", .Cells(.Rows.Count, .Columns.Count), _
                SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
            LC = .Cells.Find("*", .Cells(.Rows.Count, .Columns.Count), _
                SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column

            With .PageSetup
                .PrintArea = .Range("A1", .Cells(LR, LC)).Address
                .PrintTitleRows = "$1:$2"
                .CenterFooter = "Page &P of &N"
                .CenterVertically = False
                .PrintHeadings = False
                .Orientation = xlLandscape
                .FirstPageNumber = xlAutomatic
                .BlackAndWhite = True
            End With

            With .Range("A1", .Cells(LR, LC))
                .Borders(xlDiagonalDown).LineStyle = xlNone
                .Borders(xlDiagonalUp).LineStyle = xlNone
                .Borders(xlEdgeLeft).Weight = xlMedium
                .Borders(xlEdgeTop).Weight = xlMedium
                .Borders(xlEdgeBottom).Weight = xlMedium
                .Borders(xlEdgeRight).Weight = xlMedium
                .Borders(xlInsideVertical).Weight = xlHairline
                .Borders(xlInsideHorizontal).Weight = xlHairline
            End With
          End With
        End If
    Next ws
    
    Application.ScreenUpdating = True
End Sub

**jsantos** · 10-22-2012, 08:33 PM

Many Many thanks
This ends my long list of requests.

Untill the next time

Kind regards
Jsantos

Print area and borders macro based on cells contents

LinkBack

Thread Tools

Rate This Thread

Display

Hybrid View

Print area and borders macro based on cells contents

Re: Print area and borders macro based on cells contents

Re: Print area and borders macro based on cells contents

Re: Print area and borders macro based on cells contents

Re: Print area and borders macro based on cells contents

Re: Print area and borders macro based on cells contents

Re: Print area and borders macro based on cells contents

Re: Print area and borders macro based on cells contents

Re: Print area and borders macro based on cells contents

Re: Print area and borders macro based on cells contents

Thread Information

Users Browsing this Thread

Bookmarks

Bookmarks

Posting Permissions