Code verkürzen

Forumthread: Code verkürzen

Code verkürzen

15.08.2004 01:04:46

Sigi

Hallo Spezialisten,
ich bage immer wieder das Problem Code kurzzu halten.
z.B
Nachforlgender Code ei kann ich diesen umgehen?
Gruß
Sigi


Sub AlleFiltern()
Worksheets("1").Columns("B:B").NumberFormat = "dd.mm.yyyy"
Worksheets("1").Range("A1").AutoFilter _
Field:=1, Criteria1:="=" & Format(CDate(Range("A1").Value), "dd.mm.yyyy")
Worksheets(1).Columns("B:B").NumberFormat = "dd.mm.yyyy"
Worksheets("2").Columns("B:B").NumberFormat = "dd.mm.yyyy"
Worksheets("2").Range("A1").AutoFilter _
Field:=1, Criteria1:="=" & Format(CDate(Range("A1").Value), "dd.mm.yyyy")
Worksheets(2).Columns("B:B").NumberFormat = "dd.mm.yyyy"
Worksheets("3").Columns("B:B").NumberFormat = "dd.mm.yyyy"
Worksheets("3").Range("A1").AutoFilter _
Field:=1, Criteria1:="=" & Format(CDate(Range("A1").Value), "dd.mm.yyyy")
Worksheets(3).Columns("B:B").NumberFormat = "dd.mm.yyyy"
Worksheets("4").Columns("B:B").NumberFormat = "dd.mm.yyyy"
Worksheets("4").Range("A1").AutoFilter _
Field:=1, Criteria1:="=" & Format(CDate(Range("A1").Value), "dd.mm.yyyy")
Worksheets(4).Columns("B:B").NumberFormat = "dd.mm.yyyy"
Worksheets("5").Columns("B:B").NumberFormat = "dd.mm.yyyy"
Worksheets("5").Range("A1").AutoFilter _
Field:=1, Criteria1:="=" & Format(CDate(Range("A1").Value), "dd.mm.yyyy")
Worksheets(5).Columns("B:B").NumberFormat = "dd.mm.yyyy"
Worksheets("6").Columns("B:B").NumberFormat = "dd.mm.yyyy"
Worksheets("6").Range("A1").AutoFilter _
Field:=1, Criteria1:="=" & Format(CDate(Range("A1").Value), "dd.mm.yyyy")
Worksheets(6).Columns("B:B").NumberFormat = "dd.mm.yyyy"
Worksheets("7").Columns("B:B").NumberFormat = "dd.mm.yyyy"
Worksheets("7").Range("A1").AutoFilter _
Field:=1, Criteria1:="=" & Format(CDate(Range("A1").Value), "dd.mm.yyyy")
Worksheets(7).Columns("B:B").NumberFormat = "dd.mm.yyyy"
Worksheets("8").Columns("B:B").NumberFormat = "dd.mm.yyyy"
Worksheets("8").Range("A1").AutoFilter _
Field:=1, Criteria1:="=" & Format(CDate(Range("A1").Value), "dd.mm.yyyy")
Worksheets(8).Columns("B:B").NumberFormat = "dd.mm.yyyy"
Kopieren
End Sub


Sub Kopieren()
Dim iRow As Integer
Dim rng As Range
Application.ScreenUpdating = False
If Worksheets("Print").Visible = False Then Worksheets("Print").Visible = True
If Worksheets("1").Visible = False Then Worksheets("1").Visible = True
Sheets("1").Select
If Range("L1").Value = 0 Then GoTo Weiter01
Set rng = Range(Cells(1, 1), _
Cells(Cells(1, 2).End(xlDown).Row, 10))
ActiveSheet.PageSetup.PrintArea = rng.Address
Application.Goto Reference:="Print_Area"
Selection.Copy
Sheets("Print").Select
Range("A2").Select
Selection.PasteSpecial Paste:=xlAll, Operation:=xlNone, SkipBlanks:=False _
, Transpose:=True
Range("A1").Select
Weiter01:
If Worksheets("2").Visible = False Then Worksheets("2").Visible = True
Sheets("2").Select
If Range("N1").Value = 0 Then GoTo Weiter02
Set rng = Range(Cells(1, 1), _
Cells(Cells(1, 2).End(xlDown).Row, 12))
ActiveSheet.PageSetup.PrintArea = rng.Address
Application.Goto Reference:="Print_Area"
Selection.Copy
Sheets("Print").Select
Range("A13").Select
Selection.PasteSpecial Paste:=xlAll, Operation:=xlNone, SkipBlanks:=False _
, Transpose:=True
Weiter02:
If Worksheets("3").Visible = False Then Worksheets("3").Visible = True
Sheets("3").Select
If Range("S1").Value = 0 Then GoTo Weiter03
Set rng = Range(Cells(1, 1), _
Cells(Cells(1, 2).End(xlDown).Row, 17))
ActiveSheet.PageSetup.PrintArea = rng.Address
Application.Goto Reference:="Print_Area"
Selection.Copy
Sheets("Print").Select
Range("A26").Select
Selection.PasteSpecial Paste:=xlAll, Operation:=xlNone, SkipBlanks:=False _
, Transpose:=True
Weiter03:
If Worksheets("4").Visible = False Then Worksheets("4").Visible = True
Sheets("4").Select
If Range("Y1").Value = 0 Then GoTo Weiter04
Set rng = Range(Cells(1, 1), _
Cells(Cells(1, 2).End(xlDown).Row, 23))
ActiveSheet.PageSetup.PrintArea = rng.Address
Application.Goto Reference:="Print_Area"
Selection.Copy
Sheets("Print").Select
Range("A44").Select
Selection.PasteSpecial Paste:=xlAll, Operation:=xlNone, SkipBlanks:=False _
, Transpose:=True
Weiter04:
If Worksheets("5").Visible = False Then Worksheets("5").Visible = True
Sheets("5").Select
If Range("I1").Value = 0 Then GoTo Weiter05
Set rng = Range(Cells(1, 1), _
Cells(Cells(1, 2).End(xlDown).Row, 7))
ActiveSheet.PageSetup.PrintArea = rng.Address
Application.Goto Reference:="Print_Area"
Selection.Copy
Sheets("Print").Select
Range("A68").Select
Selection.PasteSpecial Paste:=xlAll, Operation:=xlNone, SkipBlanks:=False _
, Transpose:=True
Range("A1").Select
Weiter05:
If Worksheets("6").Visible = False Then Worksheets("6").Visible = True
Sheets("6").Select
If Range("H1").Value = 0 Then GoTo Weiter06
Set rng = Range(Cells(1, 1), _
Cells(Cells(1, 2).End(xlDown).Row, 6))
ActiveSheet.PageSetup.PrintArea = rng.Address
Application.Goto Reference:="Print_Area"
Selection.Copy
Sheets("Print").Select
Range("A76").Select
Selection.PasteSpecial Paste:=xlAll, Operation:=xlNone, SkipBlanks:=False _
, Transpose:=True
Range("A1").Select
Weiter06:
If Worksheets("7").Visible = False Then Worksheets("7").Visible = True
Sheets("7").Select
If Range("I1").Value = 0 Then GoTo Weiter07
Set rng = Range(Cells(1, 1), _
Cells(Cells(1, 2).End(xlDown).Row, 7))
ActiveSheet.PageSetup.PrintArea = rng.Address
Application.Goto Reference:="Print_Area"
Selection.Copy
Sheets("Print").Select
Range("A83").Select
Selection.PasteSpecial Paste:=xlAll, Operation:=xlNone, SkipBlanks:=False _
, Transpose:=True
Range("A1").Select
Weiter07:
If Worksheets("8").Visible = False Then Worksheets("8").Visible = True
Sheets("8").Select
If Range("K1").Value = 0 Then GoTo Weiter08
Set rng = Range(Cells(1, 1), _
Cells(Cells(1, 2).End(xlDown).Row, 9))
ActiveSheet.PageSetup.PrintArea = rng.Address
Application.Goto Reference:="Print_Area"
Selection.Copy
Sheets("Print").Select
Range("A91").Select
Selection.PasteSpecial Paste:=xlAll, Operation:=xlNone, SkipBlanks:=False _
, Transpose:=True
Range("A1").Select
Weiter08:
Sheets("Print").Select
Range("A1").Select
Call Filteraufheben
End Sub


Sub Filteraufheben()
Application.ScreenUpdating = False
Worksheets("1").AutoFilterMode = False
Worksheets("1").Visible = False
Worksheets("2").AutoFilterMode = False
Worksheets("2").Visible = False
Worksheets("3").AutoFilterMode = False
Worksheets("3").Visible = False
Worksheets("4").AutoFilterMode = False
Worksheets("4").Visible = False
Worksheets("5").AutoFilterMode = False
Worksheets("5").Visible = False
Worksheets("6").AutoFilterMode = False
Worksheets("6").Visible = False
Worksheets("7").AutoFilterMode = False
Worksheets("7").Visible = False
Worksheets("8").AutoFilterMode = False
Worksheets("8").Visible = False
If Worksheets("1").Visible = True Then Worksheets("1").Visible = False
If Worksheets("2").Visible = True Then Worksheets("2").Visible = False
If Worksheets("3").Visible = True Then Worksheets("3").Visible = False
If Worksheets("4").Visible = True Then Worksheets("4").Visible = False
If Worksheets("5").Visible = True Then Worksheets("5").Visible = False
If Worksheets("6").Visible = True Then Worksheets("6").Visible = False
If Worksheets("7").Visible = True Then Worksheets("7").Visible = False
If Worksheets("8").Visible = True Then Worksheets("8").Visible = False
'If Worksheets("Print").Visible = True Then Worksheets("Print").Visible = False
Sheets("Print").Select
Application.ScreenUpdating = True
End Sub

2
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

AW: Code verkürzen

15.08.2004 04:50:58

Hans
Danke Hans! o.T.

15.08.2004 09:42:29

Sigi

AW: Code verkürzen

15.08.2004 04:50:58

Hans

Hallo Sigi,
da lässt sich leider nicht viel machen:


Sub Drucken()
Dim iWks As Integer
Application.ScreenUpdating = False
For iWks = 1 To 8
With Worksheets(CStr(iWks))
If .Range("E2") <> 0 Then
Worksheets("Print").Cells.Clear
.Columns("A:B").NumberFormat = "dd.mm.yyyy"
.Range("A2").AutoFilter Field:=1, _
Criteria1:="=" & Format(CDate(.Range("E1").Value), "dd.mm.yyyy")
.Range(.Cells(1, 1), .Cells(.Cells(1, 2).End(xlDown).Row, 2)).Copy _
Worksheets("Print").Range("A2")
With Worksheets("Print")
.Visible = True
.PrintPreview
.Visible = xlVeryHidden
End With
.AutoFilterMode = False
End If
End With
Next iWks
Application.ScreenUpdating = True
End Sub

Ich habe den Code geringfügig angepasst, damit ich ihn testen konnte. Die zugehörige Beispielarbeitsmappe findest Du hier:
https://www.herber.de/bbs/texte/0260.zip
Ein paar goldenen Regeln für sauberes Programmieren:
- nie Selektieren und Aktivieren
- der Cursor ist ein fauler Hund und möchte seine Ruhe haben
- Schleifen bilden
- With-Rahmen bilden
- mit Objektvariablen arbeiten
- Variablen sauber deklarieren
Naja, es gibt noch ein paar, die gehen aber aus den xlBasics der Excel-FAQ hervor.
Gruss hans

Danke Hans! o.T.

15.08.2004 09:42:29

Sigi

Beliebteste Forumthreads (12 Monate)

Forumthread: Code verkürzen

2 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Forumthreads zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

2
Beiträge zum Forumthread

Beiträge zu diesem Forumthread