删除列中的空白单元格

以下代码将一个值表转换为一个列。

问题是，在我的表格中，每列中的行数减less了一个。 类似于下面的表格。

我是非常新的编写代码，只知道非常基础。 我复制了一个在线发现的脚本，将一系列值转换为一个列。 我写的删除任何空白单元的代码部分会大大减慢代码的速度。 要将大约25万个点转换成一个列大约需要9个小时。 我希望能缩短处理时间，因为这是我期望经常使用的脚本。

Sub CombineColumns() Application.ScreenUpdating = False Application.EnableEvents = False Dim rng As Range Dim iCol As Long Dim lastCell As Long Dim K As Long K = 484 'set K equal to the number of data points that created the range Set rng = ActiveCell.CurrentRegion lastCell = rng.Columns(1).Rows.count + 1 For iCol = 2 To rng.Columns.count Range(Cells(1, iCol), Cells(rng.Columns(iCol).Rows.count, iCol)).Cut ActiveSheet.Paste Destination:=Cells(lastCell, 1) lastCell = lastCell + rng.Columns(iCol).Rows.count Next iCol Dim z As Long Dim m As Long z = K ^ 2 For Row = z To 1 Step -1 If Cells(Row, 1) = 0 Then Range("A" & Row).Delete Shift:=xlUp Application.StatusBar = "Progress: " & Row & " of z: " & Format((z - Row) / z, "Percent") DoEvents End If Next Application.StatusBar = False Application.ScreenUpdating = True Application.EnableEvents = True End Sub 

样本表结构

Answer 1

因为我提供了错误的信息，应该在哪里发布。

下面的代码将几乎立即做你想做的事情。

我使用数组来限制与工作表的交互次数。

 Sub foo5() Dim ws As Worksheet Dim rng() As Variant Dim oarr() As Variant Dim i&, j&, k& Set ws = ThisWorkbook.Worksheets("Sheet19") 'Change to your sheet With ws rng = .Range("A1", .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row, .Cells(1, .Columns.Count).End(xlToLeft))).Value ReDim oarr(1 To Application.WorksheetFunction.CountA(rng), 1 To 1) k = 1 For i = LBound(rng, 1) To UBound(rng, 1) For j = LBound(rng, 2) To UBound(rng, 2) If rng(i, j) <> "" Then oarr(k, 1) = rng(i, j) k = k + 1 End If Next j Next i .Range("A1", .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row, .Cells(1, .Columns.Count).End(xlToLeft))).Clear .Range("A1").Resize(UBound(oarr), 1).Value = oarr End With End Sub