删除列中的空白单元格

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