nur ein Hinweis,
14.03.2016 15:59:31
Michael
Hi Alex,
ich persönlich mag keine Datein, die auf irgendwelchen Servern liegen - es muß doch möglich sein, sie so abzuspecken, daß sie ins Forum passen: ca. 350 KB ist schon ein Haufen Holz!
Aber gut: ich sehe beim Überfliegen nirgends "10 Schleifen"; gib bitte an, in welchem Modul welche Sub/Function der Übeltäter ist.
Was definitiv falsch ist, ist der Block in Modul1:
Sub gruppieren() ' Hier soll auch eine Fortschrittsbalken hinterlegt werden
Dim rngZelle As Range
For Each rngZelle In Worksheets("PM").UsedRange.Columns(1).Cells
If Left(rngZelle.Value, 2) = "1." Or _
Left(rngZelle.Value, 2) = "2." Or _
Left(rngZelle.Value, 2) = "3." Or _
Left(rngZelle.Value, 2) = "4." Or _
Left(rngZelle.Value, 2) = "5." Or _
Left(rngZelle.Value, 2) = "6." Or _
Left(rngZelle.Value, 2) = "7." Or _
Left(rngZelle.Value, 2) = "8." Or _
Left(rngZelle.Value, 2) = "9." Or _
Left(rngZelle.Value, 2) = "10." Or _
Left(rngZelle.Value, 2) = "11." Or _
Left(rngZelle.Value, 2) = "12." Or _
Left(rngZelle.Value, 2) = "13." Or _
Left(rngZelle.Value, 2) = "14." Or _
Left(rngZelle.Value, 2) = "15." Or _
Left(rngZelle.Value, 2) = "16." Or _
Left(rngZelle.Value, 2) = "17." Or _
Left(rngZelle.Value, 2) = "18." Or _
Left(rngZelle.Value, 2) = "19." Or _
Left(rngZelle.Value, 2) = "20." Then
rngZelle.Rows.Group
End If
Next rngZelle
ActiveSheet.Outline.ShowLevels RowLevels:=1
End Sub
Das Ding ist a) relativ langsam, weil es alle Zellen "im Blatt" durchläuft; das Ermitteln des untersten Wertes und Laden in ein Array ist ein bißchen schneller.
Der "echte" Fehler ist allerdings die Abfrage ab "10.": mit "left" holst Du Dir nur die linken 2 Werte, und "10." hat 3 Zeichen. Ich würde nach dem "." suchen, und wenn der an 2. oder 3. Position liegt, schauen, ob links Zahlen bzw. Ziffern sind:
Sub gruppieren() ' Hier soll auch eine Fortschrittsbalken hinterlegt werden
Dim rngZelle As Range
Dim t As String, p As Long
Const ziffern = ".1.2.3.4.5.6.7.8.9.10.11.12.13.14.15.16.17.18.19.20."
For Each rngZelle In Worksheets("PM").UsedRange.Columns(1).Cells
t = rngZelle.Text
p = InStr(t, ".")
If p = 2 Or p = 3 Then
t = Left(t, p)
If InStr(ziffern, "." & t) > 0 Then rngZelle.Rows.Group
End If
Next rngZelle
ActiveSheet.Outline.ShowLevels RowLevels:=1
End Sub
Vielleicht hilft Dir das ein Stückchen weiter...
Schöne Grüße,
Michael