Code verkürzen

Bewerten Sie hier bitte das Excel-Portal

Der kurze Weg zum Ziel: Auftragsprogrammierung

Code verkürzen

Code verkürzen von Sigi vom 15.08.2004 01:04:46

AW: Code verkürzen - von Hans W. Herber am 15.08.2004 04:50:58
- Danke Hans! o.T. - von Sigi am 15.08.2004 09:42:29

Betrifft: Code verkürzen von: Sigi
Geschrieben am: 15.08.2004 01:04:46

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

Betrifft: AW: Code verkürzen von: Hans W. Herber
Geschrieben am: 15.08.2004 04:50:58

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

Betrifft: Danke Hans! o.T. von: Sigi
Geschrieben am: 15.08.2004 09:42:29

'

Herbers Excel/VBA-Archiv

Der kurze Weg zum Ziel: Auftragsprogrammierung

Code verkürzen