Copy a range into a single column - values only

Question

Hello I am trying to copy a range into a single column. The range is a mix of blank cells and cells with values.I only want to copy and paste the cells with values and I would it to find the first blank cell and want it to walk itself down the column from there.

The code I have right now (besides taking forever) pastes in the first row.

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

This will work:

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 2

Perhaps this will be a little faster (even though it seems to have been slow arriving).

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

The above code was modified to append the result to column G instead of over-writing existing cell values.

Answer 3

Do you need copy the whole row into one cell, row by row? For each loop shall be faster. I guess, this should work

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

its quick for this range.