AW: Dropdown / Kombinationsfeld und Autofilter
03.08.2012 22:35:44
fcs
Hallo delenn
mit folgenden Ergänzung wird der Druckbereich an die vorhanden Zellen mit Daten angepasst.
Gruß
Franz
Private Sub Worksheet_Change(ByVal Target As Range)
Dim wksAuswahl As Worksheet, lngZeile As Long, rngZelle As Range
Dim wksGrund As Worksheet, lngZeileG As Long
If Target.Range("A1").Address = "$B$1" Then
Application.EnableEvents = False
If MsgBox("Daten zu Veranstaltung """ & Target.Range("A1").Value _
& """ in ""Auswahltabelle"" übertragen?", _
vbQuestion + vbOKCancel, "Adressen übertragen") = vbOK Then
strVeranstaltung = Target.Range("A1").Value
Set wksAuswahl = Me
'vorhandene Daten löschen/überschreiben
With wksAuswahl
lngZeile = .Cells.SpecialCells(xlCellTypeLastCell).Row
If lngZeile > 2 Then
.Range(.Rows(3), .Rows(lngZeile)).ClearContents
End If
End With
With Worksheets("Grundtabelle")
'Autofilter in Grundtabelle prüfen und setzen
If .AutoFilterMode = True Then
If .FilterMode = True Then .ShowAllData
Else
.Range(.Cells(1, 1), .Cells.SpecialCells(xlCellTypeLastCell)).AutoFilter
End If
'Zelle mit Veranstaltung in Zeile 1 suchen
Set rngZelle = .Range("Veranstaltungen").Find(what:=strVeranstaltung, _
LookIn:=xlValues, lookat:=xlWhole)
.AutoFilter.Range.AutoFilter Field:=rngZelle.Column, Criteria1:="X"
lngZeileG = .Cells(.Rows.Count, rngZelle.Column).End(xlUp).Row
If lngZeileG > 1 Then
.Range(.Cells(2, 6), .Cells(lngZeileG, 13)).Copy Destination:=wksAuswahl.Cells(3, 1)
End If
.ShowAllData
End With
Else
Target.Range("A1").Value = strVeranstaltung
End If
' NEU - Anfang ####
Application.PrintCommunication = False
With wksAuswahl
lngZeile = .Cells(.Rows.Count, 1).End(xlUp).Row
.PageSetup.PrintTitleRows = "$1:$2"
.PageSetup.PrintTitleColumns = ""
If lngZeile > 2 Then
.PageSetup.PrintArea = .Range(.Cells(3, 1), .Cells(lngZeile, 8)).Address(ReferenceStyle:=xlA1)
Else
.PageSetup.PrintArea = .Range(.Cells(3, 1), .Cells(3, 8)).Address(ReferenceStyle:=xlA1)
End If
End With
Application.PrintCommunication = True
'NEU - Ende ####
Application.EnableEvents = True
Range("A1").Select
End If
End Sub