AW: Nur bestimmte Tabellenblätter auflisten
21.06.2013 17:54:56
Martin
hallo NoNet!
ich habe nun versucht, den code fuer mich noch anzupassen. dabei bin ich auf ein problem gestossen, dass er mich nicht in mein sub zum ausdrucken springen laesst. ich habe unten nochmals die relevanten teile angehangt. kannst du mir bitte dabei nochmals behilflich sein?
danke im voraus,
lg
martin
Sub SectorDropdown()
Dim sheet As Worksheet
With Application.CommandBars(1)
On Error Resume Next
.FindControl(Tag:="PrintSectorID").Delete
On Error GoTo 0
With .Controls.Add( _
Type:=msoControlPopup, _
before:=.Controls("&?").Index, _
temporary:=True)
.Caption = "&Print Sector ID"
.Tag = "PrintSectorID"
For Each sheet In Sheets
If UCase(sheet.Name) Like "SECTOR ID*" Then
With .Controls.Add(Type:=msoControlButton)
.Caption = sheet.Name
.Style = msoButtonCaption
.OnAction = "'DruckenSectorID (""" & sheet.Name & """)'"
.State = msoButtonUp
End With
End If
Next sheet
End With
End With
End Sub
Sub DruckenSectorID (""" & sheet.Name & """)
On Error GoTo ErrorHandler
Application.ScreenUpdating = False
Sheets(""" & sheet.Name & """).Activate
Dim AnzahlEinträgeZeilen As Integer
Dim AnzahlEinträgeSpalten As Integer
AnzahlEinträgeZeilen = WorksheetFunction.CountA(Sheets("" & sheet.Name & """).Range("A:A"))
AnzahlEinträgeSpalten = WorksheetFunction.CountA(Sheets("" & sheet.Name & """).Range("1:1")) _
' ActiveSheet.Cells.EntireColumn.HorizontalAlignment = xlCenter
Rows("1:1").EntireRow.HorizontalAlignment = xlCenter
ActiveSheet.PageSetup.PrintArea = _
Range(Cells(1, 1), Cells(AnzahlEinträgeZeilen, AnzahlEinträgeSpalten)).Address
With ActiveSheet.PageSetup
.PrintTitleRows = "$1:$1"
.PrintTitleColumns = ""
End With
'Strichlierungen einfügen
Cells.EntireColumn.Borders(xlEdgeTop).LineStyle = xlDot
Cells.EntireColumn.Borders(xlEdgeRight).LineStyle = xlDot
Cells.EntireColumn.Borders(xlEdgeLeft).LineStyle = xlDot
Cells.EntireColumn.Borders(xlInsideVertical).LineStyle = xlDot
Cells.EntireColumn.Borders(xlInsideHorizontal).LineStyle = xlDot
Rows("1:1").Borders(xlEdgeBottom).LineStyle = xlDouble
ActiveSheet.PageSetup.PrintArea = _
Range(Cells(1, 1), Cells(AnzahlEinträgeZeilen, AnzahlEinträgeSpalten)).Address
With ActiveSheet.PageSetup
.Orientation = xlLandscape
.Draft = False
.PaperSize = xlPaperA4
.FirstPageNumber = xlAutomatic
.Order = xlDownThenOver
.BlackAndWhite = False
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = False
.CenterHeader = "Amiri Flight - SPOC Sector ID Sheet - TOP SECRET"
.LeftFooter = "&""-,Fett""&8 &A" & Chr(10) & "Amiri Flight"
'CenterFooter = "Printed by: " & Environ("username") 'Das waere mit Username Zusatz, _
so wie der User am Computer angemeldet ist
.CenterFooter = "TOP SECRET!"
.RightFooter = "&8&D - &t" & Chr(10) & "Page &P of &N"
.PrintErrors = xlPrintErrorsDisplayed
End With
Application.ScreenUpdating = True
'Dim a As String
'a = MsgBox("This is a very big file! Are you sure you want to print this file?", vbYesNo, " _
CHECK IF YOU NEED TO PRINT THIS FILE")
'If a = vbNo Then
' GoTo keindruck
'End If
Application.Dialogs(xlDialogPrint).Show
keindruck:
Rows("1:1").EntireRow.HorizontalAlignment = xlLeft
'Strichlierungen entfernen
Rows("1:1").Borders(xlEdgeBottom).LineStyle = xlNone
Cells.EntireColumn.Borders(xlEdgeTop).LineStyle = xlNone
Cells.EntireColumn.Borders(xlInsideVertical).LineStyle = xlNone
Cells.EntireColumn.Borders(xlInsideHorizontal).LineStyle = xlNone
Cells.EntireColumn.Borders(xlEdgeRight).LineStyle = xlNone
Cells.EntireColumn.Borders(xlEdgeLeft).LineStyle = xlNone
ErrorHandler:
On Error GoTo 0
End Sub