in meiner Tabelle möchte ich nur bei ausgewählten Blättern den Druckbereich z.B.: (A5:G35) über VBA mit Paßwortabfrage zuweisen.
Kann mir hier jemand helfen?
Danke und Gruß Markus
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