Question

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

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

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

您知道是否有办法做到这一点，或者是否可以实施其他选择？

谢谢！

Answer 1

即使在联盟进行了优化的情况下，穿过细胞的循环也要花费很长时间。下面的代码在模仿的数据集上进行了测试，该数据集包含5列x 200,000条记录，并在5.5秒内完成。

设置：假设您的源数据在名为“源”的工作表中的范围为“ A1：E200000”，并且您希望在名为“目标”的工作表中的相似范围中的干净数据。

代码：

::

工作原理：子Remove_Empty_Cells按列循环遍历源范围，并调用子“ Clean_Column”从提供的列中删除空单元格。

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

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

一些警告：

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

[编辑]：使用数组实现的替代解决方案。同一数据集5x 200,000和40,000个有效记录的清除时间不到1秒。可以进一步优化它，我只是制作了一个快速演示的原型。

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

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“图像中的样本数据”。

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

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

2 个答案: