Question

我有一些代码用于压缩excel中的多个列，删除任何空白单元格并向上分流数据。

每个单元格都包含公式，我确实找到了一个允许我使用specialcells命令的代码片段，但是只删除了真正的空白单元格而不是包含公式的单元格，其结果会使单元格为空。

这就是我目前正在使用的内容，这是我刚才在此网站上发现的内容的编辑：

Sub condensey()
Dim c As Range
Dim SrchRng

Set SrchRng = ActiveSheet.Range("B2", ActiveSheet.Range("B208").End(xlUp))
Do
    Set c = SrchRng.Find("", LookIn:=xlValues)
    If Not c Is Nothing Then c.Delete
Loop While Not c Is Nothing
End Sub

我尝试增加活动工作表上的范围以包含第二列，但excel只是疯了，假设它正在尝试为整个表中的每个单元格执行此操作。

然后，我为每个要浓缩的列重复了这段代码。

现在这很棒，它完全符合我的要求，但它的速度很慢，特别是当每列最多可包含200多行时。关于如何提高性能的任何想法，或者可能使用不同的方法重写它？

Answer 1

这在300rows x 3cols

上以<1秒的速度运行

Sub DeleteIfEmpty(rng As Range)
    Dim c As Range, del As Range
    For Each c In rng.Cells
        If Len(c.Value) = 0 Then
            If del Is Nothing Then
                Set del = c
            Else
                Set del = Application.Union(del, c)
            End If
        End If
    Next c
    If Not del Is Nothing Then del.Delete
End Sub

Answer 2

我发现在每个列上使用AutoFilter比循环遍历范围中的每个单元格或“查找”范围中的每个空白单元格要快。使用下面的代码和一些样本数据（3列，大约300行空白和非空白单元格），在我的机器上花了0.00063657天。通过每个单元格方法使用循环，花费0.00092593天。我还在示例数据上运行了代码，花了很长时间（我没有让它完成）。到目前为止，下面的方法产生了最快的结果，但我想有人会找到一种更快的方法。

看来删除方法是最大的瓶颈。过滤非空白单元格并将其粘贴到新范围中可能是最快的，然后在完成后删除旧范围。

Sub condensey2()
Dim c As Range
Dim tbl As Range, tblWithHeader As Range, tblEnd As Range, delRng As Range
Dim i As Long
Dim maxRows As Long
Dim t As Double

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

ActiveSheet.Calculate

maxRows = ActiveSheet.Rows.Count
ActiveSheet.AutoFilterMode = False

With ActiveSheet
  Set tblEnd = Range(.Cells(maxRows, 1), .Cells(maxRows, 3)).End(xlUp)
  Set tbl = Range(.Cells(2, 1), Cells(tblEnd.Row, 3))
End With

t = Now()

Set tblWithHeader = tbl.Offset(-1).Resize(tbl.Rows.Count + 1)

i = 1
For i = 1 To tbl.Columns.Count
  With tblWithHeader
    .AutoFilter
    .AutoFilter field:=i, Criteria1:="="
  End With
  Set delRng = tbl.Columns(i).Cells.SpecialCells(xlCellTypeVisible)
  ActiveSheet.AutoFilterMode = False
  delRng.Delete xlShiftUp

  'redefine the table to make it smaller to make the filtering efficient
  With ActiveSheet
    Set tblEnd = Range(.Cells(maxRows, 1), .Cells(maxRows, 3)).End(xlUp)
    Set tbl = Range(.Cells(2, 1), Cells(tblEnd.Row, 3))
  End With
  Set tblWithHeader = tbl.Offset(-1).Resize(tbl.Rows.Count + 1)
Next i

t = Now() - t

Debug.Print Format(t, "0.00000000")

Application.ScreenUpdating = True
Application.Calculation = xlAutomatic

End Sub

在Excel中删除单元格并根据值向上移动内容

2 个答案: