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

Question

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

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



当我选择所有空白时，我的笔记本电脑大约需要 2 分钟，但是当我尝试从一列或多列中删除单元格并向上移动时，Excel 卡住并且没有任何 react 。我已经像这样离开笔记本电脑超过 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 不允许逐个字段粘贴记录集。所以我们必须逐列加载数据(如果有人知道更优化的方法，我很乐意看到它)。

几个警告:

出于某种原因 (?)，第一列复制时没有标题，而所有连续列复制时都带有标题。然后第一列必须插入标题(手动或使用 VBA)；

我假设每列中非空单元格的数量是相同的，否则清理后的记录将不会排列(如果是这种情况，你有一个更大的问题)。

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

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