删除空白单元格-146,459行 [英] Delete Blank Cells - 146,459 rows

问题描述

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

I hope you can help me with this issue.

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

I have an Excel file with 146,459 rows and I need to delete blank cells to unify my data. Here is an image of what I mean:

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

When I select all blanks, my laptop takes around 2 minutes, but then when I try to delete the cells from one or more columns and shift up, Excel freezes and nothing happen. I already left my laptop for over 1 hours like that and I didn't have any results.

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

Do you know if there's a way to do it or if any alternatives can be implemented?

预先感谢！

推荐答案

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

Working with arrays is either one of the fastest or the fastest method of dealing with large ranges of cells.

开始于：

运行代码：

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

The following was used to replicate the 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"" <[e-mail]", "from: ""no one"" <[e-mail]", _
                 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行的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！