删除excel中的单元格并根据值向上移动内容答案

【问题标题】：Delete Cells in excel and move contents up based on value删除excel中的单元格并根据值向上移动内容
【发布时间】：2014-01-22 17:55:12
【问题描述】：

我有一些代码可以在 excel 中压缩多列，删除任何空白单元格并将数据向上分流。

每个单元格都包含公式，我确实找到了一个代码 sn-p，它让我可以使用特殊的单元格命令，但它只删除了真正的空白单元格，而不是包含公式的单元格，结果会使单元格变为空白。

这是我目前正在使用的，它是我不久前在这个网站上找到的东西的编辑：

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 多行时。关于如何提高性能的任何想法，或者可能使用不同的方法重写它？

【问题讨论】：

您是否关闭了屏幕更新并将计算设置为手动？

标签： vba excel

【解决方案1】：

这在 300rows x 3cols 上运行了

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

【讨论】：

这些答案太棒了，非常感谢！如果我有代表这样做，我会投票！
+1 您也可以尝试使用循环来执行此操作（请参阅SO 15431801，但它可能不会更快

【解决方案2】：

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

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

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

【讨论】：