Schleife durch Liste und verstecke Leerzeichen

Question

Ich habe eine Liste namens "District List" auf einer Registerkarte und eine Vorlage, die durch den Namen eines Bezirks in Zelle C3 setzt. Jeder Distrikt hat eine stark variierende Anzahl von Filialen (zwischen 1 & 500+ Filialen je nach Distrikt), so dass die Berichtsvorlage in einigen Fällen viel Platz hat. Ich kam dazu, um durch die Bezirksliste zu gehen, die Registerkarte Vorlage zu kopieren, den Bezirksnamen umzubenennen, den Namen des Bezirks in Zelle C3 einzufügen, und dann habe ich eine andere Schleife, um die leeren Zeilen auszublenden.

Es funktioniert, aber es dauert ewig, wie 5 Minuten pro Registerkarte, dann nach etwa vier Tabs, bekomme ich einen Objektfehler am ersten wie Sub CreateTabsFromList.

Gibt es ein Problem mit dem Code, oder ist dies nur ein wirklich ineffizienter Weg, dies zu tun? Wenn ja, kann jemand mit einer besseren Methode helfen?

Sub HideRows() 
Dim r As Range, c As Range 
Set r = Range("a1:a1000") 'Sets range well beyond the last possible row with data 
Application.ScreenUpdating = False 
For Each c In r 
If Len(c.Text) = 0 Then 
    c.EntireRow.Hidden = True 'Hide the row if the cell in A is blank 
Else 
    c.EntireRow.Hidden = False 
End If 
Next c 
Application.ScreenUpdating = True 
End Sub 


Sub CreateSheetsFromAList() 
Dim MyCell As Range, MyRange As Range 

Set MyRange = Sheets("District List").Range("A1") 
Set MyRange = Range(MyRange, MyRange.End(xlDown)) 

For Each MyCell In MyRange 
    Sheets("Template").Copy After:=Sheets(Sheets.Count) 'creates a new worksheet 
    Range("C3").Value = MyCell.Value 'Pastes value in C3 
    Sheets(Sheets.Count).Name = MyCell.Value 'renames worksheet 
    HideRows 'Hides rows where cell in column A is "" 


Next MyCell 

End Sub

Answer 1

Löschen/Ausblenden von Zeilen, 1 von 1 ist die langsamste Methode. Verbinden Sie sie immer in einem Bereich und löschen/verstecken Sie sie in einem Durchgang. Auch das Durchschleifen von Zellen ist langsamer als das Schleifen von Arrays.

Sub HideRows() 

    Dim lCtr As Long 
    Dim rngDel As Range 
    Dim r  As Range 
    Dim arr 

    Set r = Range("a1:a1000") 'Sets range well beyond the last possible row with data 
    Application.ScreenUpdating = False 

    arr = r 
    For lCtr = LBound(arr) To UBound(arr) 
     If arr(lCtr, 1) = "" Then 
      If rngDel Is Nothing Then 
       Set rngDel = Cells(lCtr, 1) 'harcoded 1 as you are using column A 
      Else 
       Set rngDel = Union(rngDel, Cells(lCtr, 1)) 
      End If 
     End If 
    Next 


    If Not rngDel Is Nothing Then 
     rngDel.EntireRow.Hidden=True 
    End If 

    Application.ScreenUpdating = True 
End Sub 

braucht Bruchteil einer Sekunde für 1000 Zeilen.