將範圍複製到單個列中 - 僅限於值

Question

您好，我正在嘗試將範圍複製到單個列中。範圍是空白單元格和值與單元格的混合。我只想複製和粘貼具有值的單元格，我會找到第一個空白單元格，並希望它自己走下列。

我現在的代碼（除了永遠）粘貼在第一行。

Dim i As Integer 
i = 1 

ThisWorkbook.Worksheets("amount date").Select 
For Row = 51 To 100 
    For col = 2 To 1000 
     If Cells(Row, col).Value <> "" Then 
      Cells(Row, col).Copy 
      Worksheets("sheet 2").Range("G" & i).PasteSpecial xlPasteValues 
     End If 
    Next 
Next 

Do While Worksheets("sheet 2").Range("G" & i).Value <> "" 
    i = i + 1 
Loop 

End Sub 

Answer 1

也許這會更快一點（儘管它似乎到達緩慢）。

Sub CopyRangeToSingleColumn() 
    ' 20 Oct 2017 

    Dim LastRow As Long 
    Dim LastClm As Long 
    Dim Rng As Range, Cell As Range 
    Dim CellVal As Variant 
    Dim Spike(), i As Long 

    With ThisWorkbook.Worksheets("amount date") 
     With .UsedRange.Cells(.UsedRange.Cells.Count) 
      LastRow = Application.Max(Application.Min(.Row, 100), 51) 
      LastClm = .Column 
     End With 
     Set Rng = .Range(.Cells(51, "A"), .Cells(LastRow, LastClm)) 
    End With 

    ReDim Spike(Rng.Cells.Count) 
    For Each Cell In Rng 
     CellVal = Trim(Cell.Value)    ' try to access the sheet less often 
     If CellVal <> "" Then 
      Spike(i) = CellVal 
      i = i + 1 
     End If 
    Next Cell 

    If i Then 
     ReDim Preserve Spike(i) 
     With Worksheets("sheet 2") 
      LastRow = Application.Max(.Cells(.Rows.Count, "G").End(xlUp).Row, 2) 
      .Cells(LastRow, "G").Resize(UBound(Spike)).Value = Application.Transpose(Spike) 
     End With 
    End If 
End Sub 

上面的代碼進行了修改的結果附加到G列，而不是蓋寫現有單元值。

Answer 2

這將工作：

Sub qwerty() 
    Dim i As Long, r As Long, c As Long 
    i = 1 

    ThisWorkbook.Worksheets("amount date").Select 
    For r = 51 To 100 
     For c = 2 To 1000 
      If Cells(r, c).Value <> "" Then 
       Cells(r, c).Copy 
       Worksheets("sheet 2").Range("G" & i).PasteSpecial xlPasteValues 
       i = i + 1 
      End If 
     Next 
    Next 
End Sub 

Answer 3

你需要按行整行復制到一個單元格，行？對於每個循環應該更快。我想，這應該工作

Sub RowToCell() 
Dim rng As Range 
Dim rRow As Range 
Dim rRowNB As Range 
Dim cl As Range 
Dim sVal As String 


Set rng = Worksheets("Sheet3").Range("$B$51:$ALN$100") 'check this range 
For Each rRow In rng.Rows 
    On Error Resume Next 
    Set rRowNB = rRow.SpecialCells(xlCellTypeConstants) 
    Set rRowNB = Union(rRow.SpecialCells(xlCellTypeFormulas), rRow) 
    On Error GoTo 0 

    For Each cl In rRowNB.Cells 
      sVal = sVal & cl.Value 
    Next cl 
    Worksheets("sheet4").Range("G" & rRow.Row - 50).Value = sVal 
    sVal = "" 
Next rRow 


End Sub 

其快速這個範圍。