Прокрутите список и скройте пробелы

Question

У меня есть список под названием «Список округов» на одной вкладке и шаблон, который управляется путем помещения имени района в ячейку C3. В каждом округе есть дико различающееся количество филиалов (между 1 & 500+ филиалов в зависимости от района), поэтому в некоторых случаях в шаблоне отчета много пустоты. Я придумал это, чтобы пройти через список округов, скопировать вкладку «Шаблон», переименовать его в «Название округа», вставить имя района в ячейку C3, а затем у меня есть еще один цикл, чтобы скрыть пустые строки.

Он работает, но он длится вечно, как 5 минут за вкладку, а затем после четырех вкладок я получаю объектную ошибку на первом, например, Sub CreateTabsFromList.

Есть ли проблема с кодом, или это просто неэффективный способ сделать это? Если это возможно, кто-нибудь может помочь с лучшим методом?

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

Удаление/Скрытие строк, 1 к 1 является самым медленным методом. Всегда объединяйте их в один диапазон и удаляйте/спрятайте их за один раз, а также зацикливание через ячейки медленнее, чем цикл.

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 

занимает часть секунды для 1000 строк.