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

我有一些代码工作，在Excel中压缩多个列，删除任何空白单元格，并向上分stream数据。

每个单元格都包含公式，我find了一个代码片断，它允许我使用一个特殊的单元格命令，但是只删除了真正的空白单元格，而不是包含公式的单元格，其中结果会使单元格变为空白。

这是我目前正在使用的，这是我前面在这个网站上find的东西的编辑：

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

这在300令令×3次的情况下以<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天。 我也在示例数据上运行了代码，花了很多时间（我没有让它完成）。 到目前为止，下面的方法产生最快的结果，但我想有人会find一个更快的方法。

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

 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