Bitte um Code-Verbesserung
07.10.2006 12:48:55
Bernd
könnte jmd. bitte mal über folgenden Code, welchen ich mir dank dem Makrorekorder und diesem Forum zurecht gefummelt habe, und Verbesserungsvorschläge machen.
Bin für wirklich jeden Hinweis dankbar.
Zum Programm selbst: eine Liste wird nacheinander nach drei Gruppen gefilter, und jeweils untereinander in ein Blatt Meldungen eingefügt. Dabei sollen keine Leerzeilen entstehen.
----------------------------C-O-D-E-----------------------------------------
' Schaltet das Zeigen des Programmaufblaufes auf dem Bildschirm aus
Application.ScreenUpdating = False
' Sortiert Liste nach DG (Wertung)
Columns("A:I").Sort Key1:=Range("I2"), Order1:=xlDescending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
' Filtert Liste nach aktuellen Abwesenheiten.
Sheets("Gesamtliste").Select
Selection.AutoFilter Field:=7, Criteria1:="Aktuell"
' Beseitgt im Blatt "Meldung" alle verbundenen Zellen
Sheets("Meldung").Select
Dim Zelle As Range
For Each Zelle In ActiveSheet.UsedRange
If Zelle.MergeCells Then
Zelle.UnMerge
End If
Next Zelle
' Löscht den Inhalt des Blattes "Meldung"
Sheets("Meldung").Cells.ClearContents
' Fügt oberen Teil der Meldung ein
Sheets("Legende").Select
Range("Meldung_oberer_Teil").Select
Selection.Copy
Sheets("Meldung").Select
Range("A1").Select
ActiveSheet.Paste
' Fügt Überschrift von Gruppe1 ein
Sheets("Legende").Select
Range("Überschrift_Gruppe1").Select
Selection.Copy
Sheets("Meldung").Select
Range("A20").Select
ActiveSheet.Paste
' Filtert Liste nach Gruppe1 und fügt gefilterte Liste in Blatt "Meldung" ein.
Sheets("Gesamtliste").Select
Selection.AutoFilter Field:=8, Criteria1:="Gruppe1"
With ActiveWorkbook
.Worksheets("Gesamtliste").Range("A2:C30001").Copy
Destination:=.Worksheets("Meldung").Range("A21")
End With
With ActiveWorkbook
.Worksheets("Gesamtliste").Range("E2:F30001").Copy _
Destination:=.Worksheets("Meldung").Range("D21")
End With
' Fügt Überschrift Gruppe2 ein
Sheets("Legende").Select
Range("Überschrift_Gruppe2").Select
Selection.Copy
Sheets("Meldung").Select
Range("A221").Select
ActiveSheet.Paste
' Filtert Liste nach Gruppe2 und fügt gefilterte Liste in Blatt "Meldung" ein.
Sheets("Gesamtliste").Select
Selection.AutoFilter Field:=8, Criteria1:="Gruppe2"
With ActiveWorkbook
.Worksheets("Gesamtliste").Range("A2:C30001").Copy _
Destination:=.Worksheets("Meldung").Range("A222")
End With
With ActiveWorkbook
.Worksheets("Gesamtliste").Range("E2:F30001").Copy _
Destination:=.Worksheets("Meldung").Range("D222")
End With
' Fügt Überschrift Gruppe3 ein
Sheets("Legende").Select
Range("Überschrift_Gruppe3").Select
Selection.Copy
Sheets("Meldung").Select
Range("A422").Select
ActiveSheet.Paste
' Filtert Liste nach Gruppe3 und fügt gefilterte Liste in Blatt "Meldung" ein.
Sheets("Gesamtliste").Select
Selection.AutoFilter Field:=8, Criteria1:="Gruppe3"
With ActiveWorkbook
.Worksheets("Gesamtliste").Range("A2:C30001").Copy _
Destination:=.Worksheets("Meldung").Range("A423")
End With
With ActiveWorkbook
.Worksheets("Gesamtliste").Range("E2:F30001").Copy _
Destination:=.Worksheets("Meldung").Range("D423")
End With
' Hebt sämtliche Filterungen auf.
Sheets("Gesamtliste").Select
Selection.AutoFilter Field:=8
Selection.AutoFilter Field:=7
Range("A1").Select
' Löscht die Leerzeilen in Tabelle "Meldung"
Sheets("Meldung").Select
With Range("A1:A65000")
.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End With
Range("A1").Select
' Gibt Messagebox aus
MsgBox "Meldung erstellt!"
End Sub
----------------------------E-N-D-E-----------------------------------------
Gruss
Bernd