删除列中的空白单元格

Question

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

问题是，对于我的表格，每列中的行数对于每个连续的列都会减少一。类似于下表。

我对编写代码非常陌生，只知道非常基础的知识。我复制了一个在线找到的脚本，将一系列值转换为单列。我为删除任何空白单元格而编写的代码部分极大地减慢了代码速度。将大约 250,000 个点转换为一列大约需要 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