Download
Relação .doc:   15.000  Macros, Funções e  Fórmu
las

Dicas  Excel Macros VBA

Configurando minha impressão rodapé e cabeçalho
Pergunta 36:
Gostaria de poder inserir algumas configurações no rodapé e no cabeçalho de minha impressão, isto é possivel??

Resposta 36:

Sim é possível sim  através dessa macro

Sub Setup_Print()
Dim BottomRw As Integer, PrintDate, CopyW, Lfooter, PhonFoot
Dim PageSettg As Integer, LastCol
LastCol = Application.CountA(ActiveSheet.Range("1:1"))
BottomRw = Application.CountA(ActiveSheet.Range("A:A"))
If LastCol >= 6 Then
PageSettg = 1 '1=xlPortrait
Else
PageSettg = 2 '2=xlLandscape
End If
'============= Get Copyright Data ==========
PhonFoot = "&8" & Chr(34) & "Excel VBA" & Chr(34) & _
" in Area Code denotes SKY-Pager," & Chr(10) _
& "phone # 1-800-GOHAPPY" & Chr(10) & "Smile, you're on."
PrintDate = Application.Text(Now(), "mm/dd/yyyy HH:mm:ss")
CopyW = Chr(169) & Year(Now())
Lfooter = "&8" & "*=Aardvark" & Chr(10) & CopyW & _
" Confidential Property of Harvey Flapdipple"
Application.StatusBar = "Beginning page setup"
ActiveSheet.Range(Cells(2, 1), Cells(BottomRw, LastCol)).Select
With ActiveSheet.PageSetup
.LeftHeader = ""
.CenterHeader = "&""Arial,Bold""ABCDEFG Phone List" _
& Chr(10) & SpecialMsg
.RightHeader = PrintDate
.LeftFooter = Lfooter
.CenterFooter = "Page &P of &N"
.RightFooter = PhonFoot
.LeftMargin = Application.InchesToPoints(0.75)
.RightMargin = Application.InchesToPoints(0.75)
.TopMargin = Application.InchesToPoints(1)
.BottomMargin = Application.InchesToPoints(1)
.HeaderMargin = Application.InchesToPoints(0.5)
.FooterMargin = Application.InchesToPoints(0.5)
.PrintHeadings = False
.PrintGridlines = False
.PrintNotes = False
.CenterHorizontally = True
.CenterVertically = False
.Orientation = PageSettg 'Landscape or Portrait
.Draft = False
' .PaperSize = xlPaperLetter
.FirstPageNumber = xlAutomatic
.Order = xlDownThenOver
.BlackAndWhite = False
.Zoom = False
.FitToPagesWide = 1 'Force one page wide
.FitToPagesTall = False 'Still 1 wide but unlimited down
End With
ActiveWorkbook.Save
StatusBar = ""
End Sub