删除列中的空白单元格

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