AW: Druckbereich ausgewählte Blätter mit VBA
01.02.2008 15:14:39
Markus
Hier mein Makro - funktioniert aber nur für ein Blatt, ich möchte jedoch für alle ausgewählten Blätter den Druckbereich festlegen!
Bitte um Hilfe! Danke.
Sub DruckbereichFestlegen()
Dim Inp As String, ws As Worksheet, rg As Range
Set ws = ThisWorkbook.Worksheets("Master")
Set rg = ws.Range("A1:A100").Find("Administrator", , xlValues, xlWhole, xlByColumns, _
xlNext)
If rg Is Nothing Then
MsgBox "Der User 'Administrator' wurde nicht gefunden!", 16, "Fehler!"
Else
Inp = InputBox("Geben Sie das Passwort vom Administrator ein!")
If Crypto(Inp, cKey) rg.Offset(0, 1).Value Then
MsgBox "Das Passswort ist falsch!", 16, "Fehler!"
Exit Sub
Else
ActiveSheet.PageSetup.PrintArea = "B1:H533" 'Druckbereich fstlegen
ActiveSheet.HPageBreaks.Add before:=Range("B48")
ActiveSheet.HPageBreaks.Add before:=Range("B89")
ActiveSheet.HPageBreaks.Add before:=Range("B132")
ActiveSheet.HPageBreaks.Add before:=Range("B174")
ActiveSheet.HPageBreaks.Add before:=Range("B217")
ActiveSheet.HPageBreaks.Add before:=Range("B259")
ActiveSheet.HPageBreaks.Add before:=Range("B302")
ActiveSheet.HPageBreaks.Add before:=Range("B345")
ActiveSheet.HPageBreaks.Add before:=Range("B387")
ActiveSheet.HPageBreaks.Add before:=Range("B430")
ActiveSheet.HPageBreaks.Add before:=Range("B472")
ActiveSheet.HPageBreaks.Add before:=Range("B515")
With ActiveSheet.PageSetup
.PrintTitleRows = "$1:$4"
.PrintTitleColumns = ""
Range("D8").Select
End With
ActiveSheet.PageSetup.PrintArea = "$B$1:$H$533"
With ActiveSheet.PageSetup
.LeftHeader = ""
.CenterHeader = ""
.RightHeader = ""
.LeftFooter = ""
.CenterFooter = ""
.RightFooter = ""
.LeftMargin = Application.InchesToPoints(0.94)
.RightMargin = Application.InchesToPoints(0.787401575)
.TopMargin = Application.InchesToPoints(0.53)
.BottomMargin = Application.InchesToPoints(0.54)
.HeaderMargin = Application.InchesToPoints(0.12)
.FooterMargin = Application.InchesToPoints(0.4921259845)
.PrintHeadings = False
.PrintGridlines = False
.PrintComments = xlPrintNoComments
.CenterHorizontally = False
.CenterVertically = False
.Orientation = xlPortrait
.Draft = False
.PaperSize = xlPaperA4
.FirstPageNumber = xlAutomatic
.Order = xlDownThenOver
.BlackAndWhite = False
.Zoom = 100
.PrintErrors = xlPrintErrorsDisplayed
End With
End If
End If
Set rg = Nothing
Set ws = Nothing
ActiveSheet.PrintPreview
End Sub