neue Excelmappe erstellen
17.04.2007 21:01:00
Korl
ich habe eine Liste mit 7 Spalten und max. 5001 Zeilen.
Der Inhalt enthält unterschiedlich viele Gruppen die jährlich neu formiert werden.
Das heißt, die Gruppen erhalten jeweils Zu- und Abgänge.
Bis her habe ich die Ergebnisse per Ausdruck dokumentiert. Dieses konnte ich bereits soweit automatisieren, indem ich mir eine UF mit einer ComboBox gebastelt habe.
In der ComboBox befinden sich die Gruppennummern, die ich einzeln für den Ausdruck aufgerufen habe.
Dies ist mein Code für die Vorbereitung zum Ausdruck.
Nun möchte ich gerne per Button eine neue Excelmappe erzeugen und pro Inhalt der ComboBox ein eigenes Tabellenblatt darin anlegen und die Inhalte dort hinein kopieren.
Sub Auslagern()
Set wksKreis = Worksheets("Kreis")
Set wksT1 = Worksheets("Temp1")
Set wksOrt = Worksheets("Ortslist")
Application.ScreenUpdating = False
Application.EnableEvents = False
'Gesamt
On Error Resume Next
wksKreis.ShowAllData
If ufAuswahl.ComboBox1.Value = "" Then
MsgBox ("Es muß schon eine KBZ-Nummer ausgesucht werden,") & vbLf & " " _
& vbLf & "die dann übernommen werden soll !"
Exit Sub
Else
lLetzteK = IIf(wksKreis.Range("D65536") "", 65536, wksKreis.Range("D65536").End(xlUp).Row)
lLetzteT = IIf(wksT1.Range("D65536") "", 65536, wksT1.Range("D65536").End(xlUp).Row)
wksKreis.Range("A1:G" & lLetzteK).AutoFilter Field:=5, Criteria1:=ufAuswahl.ComboBox1.Value, VisibleDropDown:=False
wksKreis.Range("A1").CurrentRegion.SpecialCells(xlCellTypeVisible).Copy _
wksT1.Range("A1")
lLetzteT = IIf(wksT1.Range("D65536") "", 65536, wksT1.Range("D65536").End(xlUp).Row)
Call Rahmen_setzen_gestrichelt
With wksT1
.Range("B" & lLetzteT + 2) = "KBZ"
.Range("B" & lLetzteT + 2).HorizontalAlignment = xlRight
.Range("C" & lLetzteT + 2) = ufAuswahl.ComboBox1.Value & " " & "Summe-Gesamt:"
.Range("D" & lLetzteT + 2) = wksKreis.Range("D5004").Value
.Range("D" & lLetzteT + 2).NumberFormat = "#,##0.00"
With .Range("B" & lLetzteT, "E" & lLetzteT + 2).Borders(xlEdgeBottom)
.LineStyle = xlDouble
End With
lLetzteT = IIf(wksT1.Range("D65536") "", 65536, wksT1.Range("D65536").End(xlUp).Row)
.Range("B" & lLetzteT, "E" & lLetzteT + 2).Font.Bold = True
End With
lLetzteT = IIf(wksT1.Range("D65536") "", 65536, wksT1.Range("D65536").End(xlUp).Row)
wksT1.HPageBreaks.Add Range("A" & lLetzteT + 1)
'Zugang
lLetzteK = IIf(wksKreis.Range("D65536") "", 65536, wksKreis.Range("D65536").End(xlUp).Row)
lLetzteT = IIf(wksT1.Range("D65536") "", 65536, wksT1.Range("D65536").End(xlUp).Row)
wksKreis.Range("A1:G" & lLetzteK).AutoFilter Field:=5, Criteria1:=ufAuswahl.ComboBox1.Value, VisibleDropDown:=False
wksKreis.Range("A1:G" & lLetzteT).AutoFilter Field:=6, Criteria1:="Wechsel", VisibleDropDown:=False
If wksKreis.Range("I1") = 0 Then
Else
lLetzteT = IIf(wksT1.Range("D65536") "", 65536, wksT1.Range("D65536").End(xlUp).Row)
wksT1.Range("B" & lLetzteT + 1) = "Zugang"
wksKreis.Range("A1").CurrentRegion.SpecialCells(xlCellTypeVisible).Copy _
wksT1.Range("A" & lLetzteT + 2)
With wksT1
lLetzteT = IIf(wksT1.Range("D65536") "", 65536, wksT1.Range("D65536").End(xlUp).Row)
.Range("B" & lLetzteT + 2) = "Kehrbezirk"
.Range("B" & lLetzteT + 2).HorizontalAlignment = xlRight
.Range("C" & lLetzteT + 2) = ufAuswahl.ComboBox1.Value & " " & "Summe-Zugang:"
.Range("D" & lLetzteT + 2) = wksKreis.Range("D5004").Value
.Range("D" & lLetzteT + 2).NumberFormat = "#,##0.00"
With .Range("B" & lLetzteT, "E" & lLetzteT + 2).Borders(xlEdgeBottom)
.LineStyle = xlDouble
End With
lLetzteT = IIf(wksT1.Range("D65536") "", 65536, wksT1.Range("D65536").End(xlUp).Row)
.Range("B" & lLetzteT, "E" & lLetzteT + 2).Font.Bold = True
End With
End If
'Abgang
On Error Resume Next
wksKreis.ShowAllData
lLetzteK = IIf(wksKreis.Range("D65536") "", 65536, wksKreis.Range("D65536").End(xlUp).Row)
lLetzteT = IIf(wksT1.Range("D65536") "", 65536, wksT1.Range("D65536").End(xlUp).Row)
wksKreis.Range("A1:G" & lLetzteT).AutoFilter Field:=7, Criteria1:=ufAuswahl.ComboBox1.Value, VisibleDropDown:=False
wksKreis.Range("A1:G" & lLetzteT).AutoFilter Field:=6, Criteria1:="Wechsel", VisibleDropDown:=False
If wksKreis.Range("I1") = 0 Then
Else
lLetzteT = IIf(wksT1.Range("D65536") "", 65536, wksT1.Range("D65536").End(xlUp).Row)
wksT1.Range("B" & lLetzteT + 3) = "Abgang"
wksKreis.Range("A1").CurrentRegion.SpecialCells(xlCellTypeVisible).Copy _
wksT1.Range("A" & lLetzteT + 4)
With wksT1
lLetzteT = IIf(wksT1.Range("D65536") "", 65536, wksT1.Range("D65536").End(xlUp).Row)
.Range("B" & lLetzteT + 2) = "Kehrbezirk"
.Range("B" & lLetzteT + 2).HorizontalAlignment = xlRight
.Range("C" & lLetzteT + 2) = ufAuswahl.ComboBox1.Value & " " & "Summe-Abgang:"
.Range("D" & lLetzteT + 2) = wksKreis.Range("D5004").Value
.Range("D" & lLetzteT + 2).NumberFormat = "#,##0.00"
With .Range("B" & lLetzteT, "E" & lLetzteT + 2).Borders(xlEdgeBottom)
.LineStyle = xlDouble
End With
lLetzteT = IIf(wksT1.Range("D65536") "", 65536, wksT1.Range("D65536").End(xlUp).Row)
.Range("B" & lLetzteT, "E" & lLetzteT + 2).Font.Bold = True
End With
End If
Application.EnableEvents = True
Application.ScreenUpdating = True
End If
End Sub
Ist meine Wunschvorstellung so ohne weiteres zu machen?
Gruß Korl