vba 删除excel中的单元格并根据值向上移动内容
声明：本页面是StackOverFlow热门问题的中英对照翻译，遵循CC BY-SA 4.0协议，如果您需要使用它，必须同样遵循CC BY-SA许可，注明原文地址和作者信息，同时你必须将它归于原作者（不是我）：StackOverFlow
原文地址: http://stackoverflow.com/questions/21290365/
Warning: these are provided under cc-by-sa 4.0 license. You are free to use/share it, But you must attribute it to the original authors (not me):
StackOverFlow
Delete Cells in excel and move contents up based on value
提问by GenericTechSupportAgent1
I've got some code working to condense multiple columns in excel, removing any blank cells and shunting the data upwards.
我有一些代码可以压缩 excel 中的多列，删除任何空白单元格并将数据向上分流。
Every cell contains formulae, I did find a code snippet that let me use a specialcells command, but that only removed truly blank cells and not ones that contained a formula, where the outcome would make the cell blank.
每个单元格都包含公式，我确实找到了一个代码片段，让我使用 specialcells 命令，但它只删除了真正的空白单元格，而不是包含公式的单元格，结果会使单元格空白。
This is what I'm currently using, which was an edit of something I found on this site a while ago:
这是我目前正在使用的，它是我不久前在本网站上发现的内容的编辑：
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
I tried increasing the range on the active sheet to include a second column, but excel just goes nuts, assuming it's trying to do it for every cell in the entire table.
我尝试增加活动工作表上的范围以包含第二列，但 excel 只是发疯了，假设它试图为整个表格中的每个单元格都这样做。
I've then repeated this piece of code for each column that I want to condense.
然后，我为要压缩的每一列重复了这段代码。
Now this is great, it does exactly what I want to do, but it is slow as anything, especially when each column can contain up to 200+ rows. Any ideas on how to improve the performance of this, or maybe re-write it using a different method?
现在这很棒，它完全符合我的要求，但它很慢，尤其是当每列最多可以包含 200 多行时。关于如何提高性能的任何想法，或者使用不同的方法重写它？
回答by Tim Williams
This ran in <1sec on 300rows x 3cols
这在 300 行 x 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
回答by Will Ediger
I found that using AutoFilter on each column was faster than looping through each cell in the range or "Find"ing each blank cell in the range. Using the code below and some sample data (3 columns with approximately 300 rows of blank and non blank cells), on my machine it took 0.00063657 days. Using the loop through each cell method, it took 0.00092593 days. I also ran your code on the sample data, and it took a lot longer (I didn't let it finish). So far, the method below yields the quickest results, though I imagine someone will find a faster method.
我发现在每列上使用 AutoFilter 比循环遍历范围内的每个单元格或“查找”范围内的每个空白单元格要快。使用下面的代码和一些示例数据（3 列，大约有 300 行空白和非空白单元格），在我的机器上花了 0.00063657 天。使用循环遍历每个单元格方法，需要 0.00092593 天。我还在示例数据上运行了您的代码，但花费了更长的时间（我没有让它完成）。到目前为止，下面的方法产生最快的结果，尽管我想有人会找到更快的方法。
It appears that the delete method is the biggest bottleneck. It may be fastest to filter the non-blank cells and paste them into a new range, and then delete the old range once you're finished.
看来删除方法是最大的瓶颈。过滤非空白单元格并将它们粘贴到新范围内，然后在完成后删除旧范围可能是最快的。
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
