AW: Einzelne Spalten drucken
03.06.2008 14:03:00
fcs
Hallo Hannes,
hier 2 Beipiele für dein Tabellenblatt, die Liste kannst du beliebig erweitern. Für jede Auswahlnummer muss du eine Case Anweisung anlegen.
In Zeile 5 mit den KW-Nummern ist bei einigen Einträgen ein zusätzliche Leerzeichen am Ende vorhanden. Deshalb hab ich bei der Suche nach der Kalender-Woche die Prüfung mit InStr gemacht, statt die Werte auf Gleichheit zu prüfen.
Gruß
Franz
Sub DruckAuswahl()
Dim objWks As Worksheet
Dim lngSpalte As Long
Dim lngZeile As Long
Dim varAuswahl As Variant
Dim varEingabe As Variant
Dim varEingabe2 As Variant
Dim strEingabe As String
Dim objBereich As Range
Dim intKW_min As Integer, intKW_max As Integer
Dim intSpalte_min As Integer, intSpalte_max As Integer
Dim intSpalteData As Integer
Set objWks = ActiveSheet
With objWks
'Festlegung von Einstellungen für die beiden Halbjahresblätter
Select Case .Name
Case "AV_1Halbjahr"
'Bereich für Kalenderwoche
intKW_min = 1 '1. KW im Kalender des 1. HJ (kann auch 52 aus Vorjahr sein)
intKW_max = 27 'letzte KW im Kalender des 1. HJ
'Zählnummer in Zeile 1 für Spalten/Tage
intSpalte_min = 1
intSpalte_max = 216
'Letzte Datenspalte mit Kalendertag
intSpalteData = 217 'Spalte HI
Case "AV_2Halbjahr"
'Bereich für Kalenderwoche
intKW_min = 26 '1. KW im Kalender des 2. HJ
intKW_max = 53 'letzte KW im Kalender des 2. HJ (kann auch 1 aus Folgejahr sein)
'Zählnummer in Zeile 1 für Spalten/Tage
intSpalte_min = 1
intSpalte_max = 216
'Letzte Datenspalte mit Kalendertag
intSpalteData = 217 'Spalte HI
Case Else
MsgBox "Druckmakro ist auf diese Tabellenblatt nicht anwendbar!"
GoTo Beenden
End Select
'Auswahl-Input-Box anzeigen
varAuswahl = Application.InputBox(Prompt:="Bitte die Nummer des Ausdrucks eingeben." & vbLf _
& vbLf _
& "1 = Ausdruck ab einer bestimmten Kalenderwoche(KW)" & vbLf _
& "2 = Nummernbereich Zeile 1" & vbLf _
& "3 = Noch ohne Funktion", _
Title:="Druckausgabe vorbereiten", Type:=1)
Select Case varAuswahl
Case 0
'Abbrechen wurde gewählt
Case 1 'Ausdruck ab einer bestimmten Kalenderwoche(KW)
varEingabe = Application.InputBox(Prompt:="Bitte die Nummer der KW eingeben.", _
Title:="Druckausgabe vorbereiten - ab KW", Type:=1)
If varEingabe >= intKW_min And varEingabe intKW_min Then
strEingabe = "KW " & Format(varEingabe, "00")
For lngSpalte = 2 To intSpalteData
If InStr(1, .Cells(5, lngSpalte).Value, strEingabe) > 0 Then
'Spalten von Spalte 2 bis zur KW merken
Set objBereich = .Range(.Columns(2), .Columns(lngSpalte - 1))
Exit For
End If
Next
If objBereich Is Nothing Then
MsgBox strEingabe & " wurde in Zeile 5 nicht gefunden!"
End If
End If
'Spalten ausblenden, die in Zeile 7 leer sind
For lngSpalte = lngSpalte To intSpalteData '(Spalte HI)
If .Cells(7, lngSpalte).Value = "" Then
If objBereich Is Nothing Then
Set objBereich = .Columns(lngSpalte)
Else
Set objBereich = Application.Union(objBereich, .Columns(lngSpalte))
End If
End If
Next
If Not objBereich Is Nothing Then
objBereich.EntireColumn.Hidden = True
End If
'Seite einrichten
With .PageSetup
.PrintArea = "$A$4:$HI$72"
End With
Application.ScreenUpdating = True
' .PrintOut Preview = True
.PrintPreview
Else
MsgBox "Unzulässige KW-Eingabe"
End If
Case 2 'Vorgabe eines Nummernbereichs für Zeile 1
varEingabe = Application.InputBox(Prompt:="Bitte Nummer der Startspalte (" _
& intSpalte_min & " bis " & intSpalte_max & ") eingeben", _
Title:="Druckausgabe vorbereiten - Spaltenbereich", Default:=intSpalte_min, Type:=1)
varEingabe2 = Application.InputBox(Prompt:="Bitte Nummer der letzten Spalte(" _
& intSpalte_min & " bis " & intSpalte_max & ") eingeben", _
Title:="Druckausgabe vorbereiten - Spaltenbereich-Nr. Zeile 1", Default:= _
intSpalte_max, Type:=1)
If varEingabe >= intSpalte_min And varEingabe = varEingabe And varEingabe2 varEingabe2 Then
If objBereich Is Nothing Then
Set objBereich = .Columns(lngSpalte)
Else
Set objBereich = Application.Union(objBereich, .Columns(lngSpalte))
End If
End If
Next
'Spalten ausblenden
If Not objBereich Is Nothing Then
objBereich.EntireColumn.Hidden = True
End If
'Seite einrichten
With .PageSetup
.PrintArea = "$A$4:$HI$72"
End With
Application.ScreenUpdating = True
' .PrintOut Preview = True
.PrintPreview
Else
MsgBox "Unzulässige Nummer wurde eingegeben"
End If
Case 3
MsgBox "Auswahl= 3! Noch ohne Funktion"
Case Else
MsgBox "Unzulässige Auswahl!"
End Select
End With
Beenden:
Application.ScreenUpdating = True
Set objWks = Nothing: Set objBereich = Nothing
End Sub