如何有效地抑制 excel vba 中选定列中的所有空行？

Question

我发现一些 Q/A 可以删除所选列中包含空单元格的行，例如 here。我的需求有点不同，列是由用户选择的，但这并不重要。

编辑：在我的用例中重要的是删除这些列的所有单元格都为空的行，即选定的列。

以下代码有效，但在我的 i5 上每分钟只能处理 1,000 行。在我的用例中，数据表包含几行 100k 行，这意味着要处理数小时。这是不可接受的。请问有什么技巧可以快速完成吗？

Sub DeleteRowsOfEmptyColumn() 'sh As Worksheet, col As String)
    Application.ScreenUpdating = False
    Dim sh As Excel.Worksheet: Set sh = ActiveWorkbook.ActiveSheet
    Dim col As Range: Set col = Selection.EntireColumn
    Dim cell
    Dim area As Range: Set area = Intersect(sh.UsedRange, col)
    For i = area.Rows.Count To 1 Step -1 'For Each row In area.Rows
        fKeep = False
        For Each cell In area.Rows(i).Cells
            If Not IsEmpty(cell) Then
                fKeep = True
                Exit For
            End If
        Next cell
        If Not fKeep Then
            sh.Rows(i).Delete 'rowsToDelete.Add i
        End If
    Next i  
    Application.ScreenUpdating = True
End Sub

示例：

之前：

之后：

Answer 1

我正在从事类似的项目。我选择将数据读入数组，然后处理数组中的数据，这显着缩短了运行时间。这是我用来删除/转换数据集的函数的副本：

    Option Explicit
Option Base 1
Public Function RemoveRowFromArray(Arr As Variant, Element As String, Col As Long) As Variant

Dim i, j, c, count As Long
Dim TempArr() As Variant

    For i = LBound(Arr, 1) To UBound(Arr, 1)                         ' looping through the columns to get desired value
        If Arr(i, Col) = Element Then
             count = count + 1                                                   ' Counting the number of Elements in array / matrix
                    For j = i To (UBound(Arr, 1) - 1)                       ' Looping from the row where Element is found
                        For c = LBound(Arr, 2) To UBound(Arr, 2)    ' Moving all elements in row 1 row up
                                Arr(j, c) = Arr(j + 1, c)
                        Next c
                    Next j
        End If
    Next i
    
    ' Populating TempArr to delete the last rows

ReDim TempArr((UBound(Arr, 1) - count), UBound(Arr, 2))

   For i = LBound(TempArr, 1) To UBound(TempArr, 1)
            For j = LBound(TempArr, 2) To UBound(TempArr, 2)
                    TempArr(i, j) = Arr(i, j)                                                 
            Next j
    Next i

    RemoveRowFromArray = TempArr
End Function

我对此进行了测试，似乎运行良好。需要牢记的一些重要事项

Option Base 1 - 这很重要，当您在 VBA 中声明一个 arr 时，它从索引 0 开始，当您从 Excel 中的数据集中读取 arr [arr = sheet1.Range("A:D")] 则arr起始索引为1，Option Base 1将确保所有arr从索引1开始。

函数变量是： arr - 数组/矩阵

Element - 您要搜索的字符串（在您的情况下为空）

Col - 是元素所在的列号。

Answer 2

删除空行范围

这是一个基本示例。感谢您对效率的反馈。

Option Explicit

Sub DeleteRowsOfEmptyColumn()
    
    Application.ScreenUpdating = False
    
    Dim ws As Worksheet: Set ws = ActiveSheet ' improve
    Dim crg As Range: Set crg = Selection.EntireColumn ' Columns Range
    Dim srg As Range: Set srg = Intersect(ws.UsedRange, crg) ' Source Range
    
    Dim drg As Range ' Delete Range
    Dim arg As Range ' Area Range
    Dim rrg As Range ' Row Range
    
    For Each arg In srg.Areas
        For Each rrg In arg.Rows
            If Application.CountA(rrg) = 0 Then
                If drg Is Nothing Then
                    Set drg = rrg
                Else
                    Set drg = Union(drg, rrg)
                End If
            End If
        Next rrg
    Next arg
    
    If Not drg Is Nothing Then drg.Delete
    
    Application.ScreenUpdating = True

    MsgBox "Rows deleted.", vbInformation

End Sub

Answer 3

请尝试下一种方法。它将处理选定的列或至少具有选定单元格的列。对于所有选定列空行的情况，它将删除 sheet 的整行。该代码仅选择讨论中的行。如果它们是合适的，在最后一行代码中，Select 应该替换为 Delete。它应该非常快，即使对于更大的范围，也只在空白单元格范围之间迭代：

Sub DeleteRowsOfEmptyColumnsCells()
    Dim sh As Excel.Worksheet: Set sh = ActiveSheet
    Dim col As Range: Set col = Selection.EntireColumn
    Dim area As Range: Set area = Intersect(sh.UsedRange, col)
    Dim firstCol As Long: firstCol = area.Column: Stop
    Dim areaV As Range, arr, rngDel As Range, i As Long
    On Error Resume Next 'only for the case of no any empty rows existence
     Set areaV = area.SpecialCells(xlCellTypeBlanks) 'a range of only empty cells
    On Error GoTo 0
    
    arr = getRows(areaV) 'extract all rows and number of columns
    For i = 0 To UBound(arr(0)) 'iterate between all existing rows
       If Intersect(sh.rows(arr(0)(i)), areaV).cells.count = arr(1) Then
            If rngDel Is Nothing Then
                Set rngDel = sh.cells(arr(0)(i), firstCol)
            Else
                Set rngDel = Union(rngDel, sh.cells(arr(0)(i), firstCol))
            End If
       End If
    Next i
    If Not rngDel Is Nothing Then rngDel.EntireRow.Select 'if it looks OK, Select should be replaced with Delete
End Sub

Function getRows(rng As Range) As Variant
  Dim A As Range, i As Long, countC As Long
  Dim arrCol, arrR, k As Long, R As Long, mtchC, mtchR
  ReDim arrCol(rng.cells.count): ReDim arrR(rng.cells.count)
  For Each A In rng.Areas
        For i = 1 To A.Columns.count
            For j = 1 To A.rows.count
                mtchC = Application.match(A.cells(j, i).Column, arrCol, 0)
                mtchR = Application.match(A.cells(j, i).row, arrR, 0)
                If IsError(mtchC) Then
                    arrCol(k) = A.cells(j, i).Column: k = k + 1
                End If
                If IsError(mtchR) Then
                    arrR(R) = A.cells(j, i).row: R = R + 1
                End If
            Next j
        Next i
  Next A
  ReDim Preserve arrR(R - 1)
  getRows = Array(arrR, k)
End Function

如何有效地抑制 excel vba 中选定列中的所有空行？

how to suppress efficiently all empty rows in selected columns in excel vba?

excel

optimization

vba

loops

rows

删除空行范围