刪除列中的空白單元格

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