删除空白单元格 - 146,459 行

Question

希望你能帮我解决这个问题。

我有一个包含 146,459 行的 Excel 文件，我需要删除空白单元格以统一我的数据。这是我的意思的图像：

当我选择所有空白时，我的笔记本电脑大约需要 2 分钟，但是当我尝试从一列或多列中删除单元格并向上移动时，Excel 冻结并且没有任何反应。我已经像这样离开我的笔记本电脑超过 1 小时，但我没有任何结果。

您知道是否有办法做到这一点，或者是否可以实施任何替代方案？

提前致谢！

Answer 1

循环通过单元格需要很长时间，即使使用联合优化也是如此。 下面的代码在一个模拟的数据集上进行了测试，5 列 x 200,000 条记录，并在 5.5 秒内完成。

设置： 假设您的源数据位于名为“Source”的工作表上的“A1:E200000”范围内，而您想要名为“Target”的工作表上类似范围内的干净数据。

代码：

Option Explicit

Sub Remove_Empty_Cells()
Dim Source        As Range
Dim Target        As Range
Dim i             As Integer

    Set Source = ThisWorkbook.Sheets("Source").Range("A1:E200000")
    Set Target = ThisWorkbook.Sheets("Target").Range("A1:E200000")

    For i = 1 To Source.Columns.Count
        Clean_Column Source.Columns(i), Target.Columns(i)
    Next i

End Sub


Sub Clean_Column(Source As Range, Target As Range)
Dim rs           As Object
Dim XML          As Object

    Set XML = CreateObject("MSXML2.DOMDocument")
    XML.LoadXML Source.Value(xlRangeValueMSPersistXML)

    Set rs = CreateObject("ADODB.Recordset")
    rs.Open XML

    rs.Filter = rs.Fields(0).Name & "<>null"
    Target.CopyFromRecordset rs

End Sub

它是如何工作的： Sub Remove_Empty_Cells 按列循环通过源范围，并调用从提供的列中删除空单元格的子“Clean_Column”。

Clean_Column 使用 MSXML2.DOMDocument 对象将所有列单元格加载到 ADO 记录集中。然后过滤记录集以查找非空行，并将结果复制到目标列。所有这些操作在 VBA 中都非常快。

理想情况下，我希望一次将整个范围加载到记录集中，但不幸的是 VBA 函数 CopyFromRecordset 不允许逐个字段粘贴记录集。所以我们必须逐列加载数据（如果有人知道更优化的方法，我很乐意看到它）。

几个注意事项：

1. 出于某种原因 (?)，第一列复制时没有标题，而所有连续列复制时都带有标题。然后第一列必须插入其标题（手动或使用 VBA）；
2. 我假设每列中非空单元格的数量是相同的，否则清理后的记录将不会排列（如果是这种情况，您的问题会更大）。

[编辑]： 另一种解决方案，使用数组实现。同一数据集 5x 200,000 和 40,000 条有效记录在不到 1 秒的时间内被清理干净。它可以进一步优化，我只是做了一个快速演示的原型。

Sub Remove_Empty_Cells()
Dim Source_Data()   As Variant
Dim Clean_Data()    As Variant
Dim Source_Range    As Range
Dim Target_Range    As Range
Dim Column_Count    As Long
Dim Row_Count       As Long
Dim i               As Long
Dim j               As Long
Dim k               As Long

    Set Source_Range = ThisWorkbook.Sheets("Source").Range("A1:E200000")

    Column_Count = Source_Range.Columns.Count
    Row_Count = Source_Range.Rows.Count

    ReDim Source_Data (1 To Row_Count, 1 To Column_Count)
    ReDim Clean_Data (1 To Row_Count, 1 To Column_Count)

    Source_Data = Source_Range

    For j = 1 To Column_Count
        k = 1
        For i = 1 To Row_Count
            If Source_Data(i, j) <> "" Then
                Clean_Data(k, j) = Source_Data(i, j)
                k = k + 1
            End If
        Next i
    Next j

    Set Target_Range = ThisWorkbook.Sheets("Target").Range("A1").Resize(Row_Count, Column_Count)
    Target_Range = Clean_Data

End Sub

Answer 2

使用数组是处理大范围单元格的最快或最快的方法之一。

开头：

运行代码：

Option Explicit

Sub delBlanks()
    Dim i As Long, j As Long, k As Long, arr As Variant, vals As Variant
    Dim s As Double, e As Double, c As Long

    s = Timer

    With Worksheets("sheet6")
        If .AutoFilterMode Then .AutoFilterMode = False

        'data validity check
        c = Application.CountA(.Columns(1))
        For j = 2 To 5
            If c <> Application.CountA(.Columns(j)) Then Exit For
        Next j
        If j <= 5 Then
            Debug.Print "GIGO, waste of time to continue"
            Exit Sub
        End If

        'collect offset values
        vals = .Range(.Cells(2, "A"), .Cells(.Rows.Count, "E").End(xlUp)).Value2
        ReDim arr(LBound(vals, 1) To UBound(vals, 1), _
                  LBound(vals, 2) To UBound(vals, 2))

        'loop through array coolating A"E to a single row
        i = LBound(vals, 1)
        k = LBound(arr, 1)
        Do
            For j = LBound(vals, 2) To UBound(vals, 2)
                Do While vals(i, j) = vbNullString: i = i + 1: Loop
                arr(k, j) = vals(i, j)
            Next j
            i = i + 1: k = k + 1
        Loop Until i > UBound(vals, 1)

        'put data back on worksheet
        .Cells(2, "A").Resize(UBound(arr, 1), UBound(arr, 2)) = arr
        .Cells(2, "C").Resize(UBound(arr, 1), 1).NumberFormat = "dd/mm/yyyy"
    End With

    e = Timer

    Debug.Print c - 1 & " records in " & UBound(vals, 1) & _
                " rows collated in " & Format((e - s), "0.000") & " seconds"
End Sub

结果：

30000 records in 157500 rows collated in 0.984 seconds

种子数据：

以下内容用于复制 OP 'sample-data-in-an-image'。

Sub fillBlanks()
    Dim i As Long, j As Long, k As Long, arr As Variant, vals As Variant

    vals = Array("to: ""someone"" <someone@null.com", "from: ""no one"" <no_one@null.com", _
                 Date, "\i\m\p\o\r\t\a\n\c\e\: 0", "subject: something nothing")

    ReDim arr(1 To 6, 1 To 5)

    With Worksheets("sheet6")
        .Cells(1, 1).CurrentRegion.Offset(1, 0).Clear
        For k = 1 To 30000
            j = 0
            For i = LBound(arr, 2) To UBound(arr, 2)
                If i = 2 And Not CBool(k Mod 4) Then j = j + 1
                If i = 4 Then
                    arr(i + j, i) = Format(k, vals(i - 1))
                Else
                    arr(i + j, i) = vals(i - 1)
                End If
            Next i
            .Cells(.Rows.Count, 5).End(xlUp).Offset(1, -4).Resize(UBound(arr, 1), UBound(arr, 2)) = arr
            ReDim arr(1 To 6, 1 To 5)
        Next k
    End With
End Sub