Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
760to764
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
760to764
760to764
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Inhaltsverzeichnis

nochmal schleife beschleunigen

nochmal schleife beschleunigen
10.05.2006 22:54:01
SteffenS
Hallo und guten Abend,
mit Schleifen habe ich so meine Probleme.
Ich habe eine Schleife bei der die Laufzeit ziemlich lang ist.
ein Application.ScreenUpdating=False ist in dem Code von wo das Makro gestartet wird schon drin.
Leider läuft die Schleife trotzdem ewig.
Was kann ich noch tun? Hier mein Code

Sub marke_1_2_ein()
'Marke 1 und 2 einblenden
Dim wkb As Workbook, wks As Worksheet, lgzeile As Long
For Each wks In Worksheets
'schutz_aufheben_only '(in wks)
wks.Unprotect (PSWDTP)
'alle Zeilen ausblenden
'wks.Rows("1:6000").EntireRow.Hidden = True
lgzeile = 0
Do
lgzeile = lgzeile + 1
If wks.Cells(lgzeile, 256) = "1" Then wks.Rows(lgzeile).Hidden = False
If wks.Cells(lgzeile, 256) = "2" Then wks.Rows(lgzeile).Hidden = False
If wks.Cells(lgzeile, 256) = "5" Then wks.Rows(lgzeile).Hidden = False
Loop Until lgzeile = 65536 Or wks.Cells(lgzeile, 256) = "Ende"
'schutz_setzen_only '(in wks)
wks.Protect Password:=PSWDTP, Contents:=True, Scenarios:=True, UserInterfaceOnly:=True
Next wks
End Sub

Ich komm einfach nicht weiter....ich habe mal gehört dass man dies mit union machen kann, aber dazu bin ich wahrscheinlich zu do.....
Danke im Voraus
MFG
Steffen Schmerler

11
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: nochmal schleife beschleunigen
10.05.2006 23:15:33
Josef
Hallo Steffen!
Probier mal!
Sub marke_1_2_ein()

'Marke 1 und 2 einblenden
Dim wks As Worksheet
Dim rng As Range, rngHide As Range, rngU As Range
Dim arrValues() As Variant
Dim intC As Integer
Dim strFirst As String

arrValues = Array(1, 2, 5) 'die gesuchten Werte! - Anpassen

For Each wks In Worksheets
  With wks
    'schutz_aufheben_only '(in wks)
    .Unprotect (PSWDTP)
    
    'alle Zeilen ausblenden
    '.Rows("1:6000").EntireRow.Hidden = True
    
    On Error Resume Next
    Set rngHide = .Columns(.Columns.Count).SpecialCells(xlCellTypeConstants, 1)
    On Error GoTo 0
    
    If Not rngHide Is Nothing Then
      For intC = 0 To UBound(arrValues)
        Set rng = rngHide.Find(arrValues(intC))
        If Not rng Is Nothing Then
          strFirst = rng.Address
          Do
            If rngU Is Nothing Then
              Set rngU = rng
            Else
              Set rngU = Union(rngU, rng)
            End If
            Set rng = rngHide.FindNext(rng)
          Loop While Not rng Is Nothing And rng.Address <> strFirst
        End If
      Next
    End If
    
    If Not rngU Is Nothing Then rngU.EntireRow.Hidden = False
    
    Set rngU = Nothing
    strFirst = ""
    
    'schutz_setzen_only '(in wks)
    .Protect Password:=PSWDTP, Contents:=True, Scenarios:=True, UserInterfaceOnly:=True
  End With
Next

Set rngHide = Nothing

End Sub


'******************************
'* Gruß Sepp
'*
'* Rückmeldung wäre nett!
'******************************

Anzeige
Dein Code passt, aber habe noch eine Frage
11.05.2006 07:44:21
SteffenS
Das klapp ja echt super,
wie stelle ich den Code aber um wenn ich nur alle Zeilen anzeigen will die eine 1 haben die anderen sollen sofern Sie sichtbar sind ausgeblendet werden.
Ich mache es derzeit mit:

Sub marke_1_ein()
'Marke 1 einblenden / Marke 2 ausblenden
Dim wkb As Workbook, wks As Worksheet, lgzeile As Long
For Each wks In Worksheets
'schutz_aufheben_only '(in wks)
wks.Unprotect (PSWDTP)
'alle Zeilen ausblenden
'wks.Rows("1:6000").EntireRow.Hidden = True
lgzeile = 0
Do
lgzeile = lgzeile + 1
If wks.Cells(lgzeile, 256) = "1" Then wks.Rows(lgzeile).Hidden = False
If wks.Cells(lgzeile, 256) = "2" Then wks.Rows(lgzeile).Hidden = True
Loop Until lgzeile = 65536 Or wks.Cells(lgzeile, 256) = "Ende"
'schutz_setzen_only '(in wks)
wks.Protect Password:=PSWDTP, Contents:=True, Scenarios:=True, UserInterfaceOnly:=True
Next wks
End Sub

Kannst Du vielleicht Deinen Code a bissle kommentieren, da ich mich mit diesem Union noch nicht so auskenne
Danke im Voraus
MFG
Steffen Schmerler
Anzeige
AW: Dein Code passt, aber habe noch eine Frage
11.05.2006 21:55:10
Josef
Hallo Steffen!
Probier mal diesen Code, damit brauchst du nicht für jede Konstellation eine
eigene Prozedur!
' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Sub marke_ein(Bereich As Range, ParamArray Werte() As Variant)
Dim wks As Worksheet
Dim rng As Range, rngU As Range
Dim intC As Integer
Dim strFirst As String

For Each wks In Worksheets
  With wks
    'schutz_aufheben_only '(in wks)
    .Unprotect (PSWDTP)
    
    'alle Zeilen ausblenden
    Bereich.EntireRow.Hidden = True
    
    For intC = 0 To UBound(Werte())
      Set rng = Bereich.Find(Werte(intC), lookat:=xlWhole)
      If Not rng Is Nothing Then
        strFirst = rng.Address
        Do
          If rngU Is Nothing Then
            Set rngU = rng
          Else
            Set rngU = Union(rngU, rng)
          End If
          Set rng = Bereich.FindNext(rng)
        Loop While Not rng Is Nothing And rng.Address <> strFirst
      End If
    Next
    
    
    If Not rngU Is Nothing Then rngU.EntireRow.Hidden = False
    
    Set rngU = Nothing
    strFirst = ""
    
    'schutz_setzen_only '(in wks)
    .Protect Password:=PSWDTP, Contents:=True, Scenarios:=True, UserInterfaceOnly:=True
  End With
Next

End Sub


Sub test1()

marke_ein Range("IV1:IV6000"), 1, 2, 3

End Sub


Sub test2()

marke_ein Range("IV1:IV6000"), 1

End Sub


Sub test3()

marke_ein Range("IV1:IV6000"), 1, 3, 5

End Sub


'******************************
'* Gruß Sepp
'*
'* Rückmeldung wäre nett!
'******************************

Anzeige
noch eine Frage
11.05.2006 23:10:16
SteffenS
Hallo Sepp,
ich habe zwischen den Zeilen wo in der letzten Spalte 1 oder 2 steht auch zeilen wo gar nichts drin steht.
Diese Zeilen werden dann aber nicht angefaßt. Der Code fasst nur die Zeilen an wo die oder 2 drin steht?
Sorry wenn es nervt aber so gut bin ich VBA dann doch nicht.
Danke Dir nochmal
Steffen
AW: noch eine Frage
11.05.2006 23:25:34
Josef
Hallo Steffen!
Was willst du jetzt eigentlich?
Die Zeilen wo eine 1 steht einblenden?
Zeilen mit einer 2 ausblenden?
Wenn nicht drin steht dann ein oder ausblenden?
Sorry, aber da blicke ich jetzt nicht durch!
Beschreib also, was, wann und warum ein/ausgeblendet werden soll.
'******************************
'* Gruß Sepp
'*
'* Rückmeldung wäre nett!
'******************************

Anzeige
AW: noch eine Frage --> detailierte Beschreibung
12.05.2006 08:09:24
SteffenS
Hallo Sepp,
also hier nochmal eine Beschreibung meiner Tabelle :-)))
Also ich habe in einer Tabelle in der letzten Spalte immer den Stati für eine MArke stehen.
Marke 1 steht dabei für 1, Marke 2 für 2.
Der Anwender kann nun wählen was er anzeigen will. Marke 1, Marke 2 oder beides.
zwischen diesen Zeilen mit den Statis existieren aber noch Zeilen wo nichts drin steht (z.B.: sind das Überschriftzeilen für Bereiche).
Diese Zeilen müssen dann unabhängig von der gewählten Marke immer sichtbar sein.
Sorry für meine lückenhafte Erklärung und danke nochmals für Deine Hilfe.
MFG
Steffen Schmerler
Anzeige
AW: noch eine Frage --> detailierte Beschreibung
12.05.2006 21:09:21
Josef
Hallo Steffen!
Dann probier mal so!
' **********************************************************************
' Modul: Modul2 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Sub marke_ein(Bereich As Range, ParamArray Werte() As Variant)
Dim wks As Worksheet
Dim rng As Range, rngU As Range
Dim intC As Integer
Dim strFirst As String

For Each wks In Worksheets
  With wks
    'schutz_aufheben_only '(in wks)
    .Unprotect (PSWDTP)
    
    'alle Zeilen einblenden
    Bereich.EntireRow.Hidden = False
    On Error Resume Next
    'alle Zeilen mit Zahlen ausblenden
    Bereich.SpecialCells(xlCellTypeConstants, 1).EntireRow.Hidden = True
    Err.Clear
    On Error GoTo 0
    
    For intC = 0 To UBound(Werte())
      Set rng = Bereich.Find(Werte(intC), lookat:=xlWhole)
      If Not rng Is Nothing Then
        strFirst = rng.Address
        Do
          If rngU Is Nothing Then
            Set rngU = rng
          Else
            Set rngU = Union(rngU, rng)
          End If
          Set rng = Bereich.FindNext(rng)
        Loop While Not rng Is Nothing And rng.Address <> strFirst
      End If
    Next
    
    
    If Not rngU Is Nothing Then rngU.EntireRow.Hidden = False
    
    Set rngU = Nothing
    strFirst = ""
    
    'schutz_setzen_only '(in wks)
    .Protect Password:=PSWDTP, Contents:=True, Scenarios:=True, UserInterfaceOnly:=True
  End With
Next

End Sub



Sub test1()

marke_ein Range("IV1:IV6000"), 1, 2, 3

End Sub



Sub test2()

marke_ein Range("IV1:IV6000"), 1

End Sub



Sub test3()

marke_ein Range("IV1:IV6000"), 1, 3, 5

End Sub


'******************************
'* Gruß Sepp
'*
'* Rückmeldung wäre nett!
'******************************

Anzeige
noch Problem --> bitte Hilfe
14.05.2006 18:11:18
SteffenS
Hallo Sepp,
ein Problem habe ich mit dem Code noch.
Es wird immer nur das aktive Blatt angepaßt.
Ich möchte aber alle Blätter der Mappe anpassen.
Er macht einfach das NExt des wks nicht.
Bitte hilf mir nochmal
Danke
Steffen
AW: noch Problem --> bitte Hilfe
14.05.2006 18:30:51
Josef
Hallo Steffen!
War eine Unachtsamkeit meinerseits, Sorry ;-((
So läuft's über alle Blätter!
' **********************************************************************
' Modul: Modul3 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Sub marke_ein(Bereich As String, ParamArray Werte() As Variant)
Dim wks As Worksheet
Dim rng As Range, rngU As Range
Dim intC As Integer
Dim strFirst As String

For Each wks In Worksheets
  With wks
    'schutz_aufheben_only '(in wks)
    .Unprotect (PSWDTP)
    
    'alle Zeilen einblenden
    .Range(Bereich).EntireRow.Hidden = False
    On Error Resume Next
    'alle Zeilen mit Zahlen ausblenden
    .Range(Bereich).SpecialCells(xlCellTypeConstants, 1).EntireRow.Hidden = True
    Err.Clear
    On Error GoTo 0
    
    For intC = 0 To UBound(Werte())
      Set rng = .Range(Bereich).Find(Werte(intC), lookat:=xlWhole)
      If Not rng Is Nothing Then
        strFirst = rng.Address
        Do
          If rngU Is Nothing Then
            Set rngU = rng
          Else
            Set rngU = Union(rngU, rng)
          End If
          Set rng = .Range(Bereich).FindNext(rng)
        Loop While Not rng Is Nothing And rng.Address <> strFirst
      End If
    Next
    
    
    If Not rngU Is Nothing Then rngU.EntireRow.Hidden = False
    
    Set rngU = Nothing
    strFirst = ""
    
    'schutz_setzen_only '(in wks)
    .Protect Password:=PSWDTP, Contents:=True, Scenarios:=True, UserInterfaceOnly:=True
  End With
Next

End Sub




Sub test1()

marke_ein "IV1:IV6000", 1, 2, 3

End Sub




Sub test2()

marke_ein "IV1:IV6000", 1

End Sub




Sub test3()

marke_ein "IV1:IV6000", 1, 3, 5

End Sub


'******************************
'* Gruß Sepp
'*
'* Rückmeldung wäre nett!
'******************************

Anzeige
Danke Dir jetzt gehts
14.05.2006 19:05:48
SteffenS
MFG
Steffen
AW: nochmal schleife beschleunigen
10.05.2006 23:15:59
Franz
Hallo Steffen,
ich weiß ja nicht, wieviele Tabellen in einer Arbeitsmappe enthalten sind und wieviel Zeilen in jeder Tabelle abzuarbeiten sind.
Da kommt evtl. schon einiges zusammen.
Falls in den Tabellen der Eintrag "Ende" in Spalte 256 nicht zum Abbruch der Schleife führt, dann werden in jedem Blatt 65000-ungrad Zeilen abgearbeitet - und das dauert.
Deshalb mein Änderungsvorschlag, der in der Schleife die Tabellen nur bis zur letzten mit Daten belegten Zeile bearbeitet.

Sub marke_1_2_ein()
'Marke 1 und 2 einblenden
Dim wkb As Workbook, wks As Worksheet, lgzeile As Long, lgletzte As Long
For Each wks In Worksheets
'schutz_aufheben_only '(in wks)
wks.Unprotect (PSWDTP)
'alle Zeilen ausblenden
'wks.Rows("1:6000").EntireRow.Hidden = True
lgzeile = 0
lgletzte = wks.UsedRange.Row + wks.UsedRange.Rows.Count - 1
Do
lgzeile = lgzeile + 1
If wks.Cells(lgzeile, 256) = "1" Then wks.Rows(lgzeile).Hidden = False
If wks.Cells(lgzeile, 256) = "2" Then wks.Rows(lgzeile).Hidden = False
If wks.Cells(lgzeile, 256) = "5" Then wks.Rows(lgzeile).Hidden = False
Loop Until lgzeile = lgletzte Or wks.Cells(lgzeile, 256) = "Ende"
'schutz_setzen_only '(in wks)
wks.Protect Password:=PSWDTP, Contents:=True, Scenarios:=True, UserInterfaceOnly:=True
Next wks
End Sub

Gruß
Franz
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige