Запуск макроса один раз ничего не делает.Запуск макроса снова работает

Question

У меня возникли проблемы с макросом, над которым я работал. Он используется для удаления пробелов (более миллиона пустых строк) при запуске другого отдельного макроса. Если я получу этот рабочий, я хотел бы объединить два макроса.

Вот макрос:

Sub Test()
DeleteBlankTableRows ActiveSheet.ListObjects(1)
End Sub
Sub DeleteBlankTableRows(ByVal tbl As ListObject)
Dim rng As Range
Set rng = tbl.DataBodyRange ' Get table data rows range.
Dim DirArray As Variant
DirArray = rng.Value2       ' Save table values to array.

' LOOP THROUGH ARRAY OF TABLE VALUES
Dim rowTMP As Long
Dim colTMP As Long
Dim combinedTMP As String
Dim rangeToDelete As Range

'  Loop through rows.
For rowTMP = LBound(DirArray) To UBound(DirArray)
    combinedTMP = vbNullString  ' Clear temp variable.

    ' Loop through each cell in the row and get all values combined.
    For colTMP = 1 To tbl.DataBodyRange.Columns.Count
        combinedTMP = combinedTMP & DirArray(rowTMP, colTMP)
    Next colTMP

    ' Check if row is blank.
    If combinedTMP = vbNullString Then
        ' Row is blank.  Add this blank row to the range-to-delete.
        If rangeToDelete Is Nothing Then
            Set rangeToDelete = tbl.ListRows(rowTMP).Range
        Else
            Set rangeToDelete = Union(rangeToDelete, tbl.ListRows(rowTMP).Range)
        End If
    End If
Next rowTMP

' DELETE BLANK TABLE ROWS (if any)
If Not rangeToDelete Is Nothing Then rangeToDelete.Delete
End Sub

Первый раз, когда он запускается, он загружается и работает так, как будто он будет работать. Менее минуты после загрузки ... ничего не происходит (по крайней мере, визуально). Я запускаю его снова, и он быстро загружается; на этот раз пустые строки визуально исчезли.

Answer 1

Аналогичная идея, использующая явную ссылку на родительский лист и Index и Max, чтобы определить, является ли строка пустой.

Option Explicit
Public Sub DeleteRowsIfBlank()
    Dim ws As Worksheet, table As ListObject, arr(), i As Long, counter As Long, unionRng As Range
    Set ws = ThisWorkbook.Worksheets("Sheet1")
    Set table = ws.ListObjects(1)
    arr = table.DataBodyRange.Value
    counter = table.DataBodyRange.Cells(1, 1).Row
    For i = LBound(arr, 1) To UBound(arr, 1)
        If Application.Max(Application.Index(arr, i, 0)) = 0 Then
            If Not unionRng Is Nothing Then
                Set unionRng = Union(unionRng, table.Range.Rows(counter))
            Else
                Set unionRng = table.Range.Rows(counter)
            End If
        End If
        counter = counter + 1
    Next
    If Not unionRng Is Nothing Then unionRng.Delete
End Sub