Code verkürzen

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

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

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

Beliebteste Forumthreads (12 Monate)

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

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

2
Beiträge zum Forumthread

Beiträge zu diesem Forumthread