Copying cells to a single column

[jake_barnes]

I'm currently using the code below to take an active range (about 700-800 rows, 5-7 columns) and, skipping empty cells, copy it to a single column. The code works like a champ, but it's slow. Like, one cell per second slow. Any idea how to speed things up?

Sub RequisitionColumn()
Dim rData As Range
Dim r As Range, c As Range
Dim rStart As Range
Dim counter As Integer

Set rData = Selection
On Error Resume Next
Application.DisplayAlerts = False
Set rStart = Application.InputBox(Prompt:="Select the location for the requisition loading.", Title:="Select Output Location", Type:=8)
On Error GoTo 0
Application.DisplayAlerts = True
If rStart Is Nothing Then Exit Sub
For Each r In rData.Rows
For Each c In rData.Columns
If Not IsEmpty(Cells(r.Row, c.Column)) Then
rStart.Offset(counter, 0) = Cells(r.Row, c.Column)
counter = counter + 1
End If
Next c
Next r
End Sub

 

[OfficeUser]

I am trying to make your code do something using random data. Can you tell me how it is supposed work? Thanks.

 

[mirabeau]

Sub copyit()
Dim u(), e
With Selection
ReDim u(1 To .Cells.Count, 1 To 1)
For Each e In .Value
    If Len(e) > 0 Then k = k + 1: u(k, 1) = e
Next e
If k > 0 Then Range("K1").Resize(k) = u
End With
End Sub

 

[mirabeau]

I am trying to make your code do something using random data. Can you tell me how it is supposed work? Thanks.

Select range from which to copy.
Run code.
In input box enter top cell address for copy destination.

 

[jake_barnes]

Sub copyit()
Dim u(), e
With Selection
ReDim u(1 To .Cells.Count, 1 To 1)
For Each e In .Value
    If Len(e) > 0 Then k = k + 1: u(k, 1) = e
Next e
If k > 0 Then Range("K1").Resize(k) = u
End With
End Sub

This was certainly quick, but I need to read the cells across the rows first.

 

[mirabeau]

How about?

Sub copyit2()
Dim u(), e, rs
With Selection
ReDim u(1 To .Cells.Count, 1 To 1)
For Each rs In .Rows
    For Each e In rs.Value
    If Len(e) > 0 Then k = k + 1: u(k, 1) = e
Next e, rs
If k > 0 Then Range("K1").Resize(k) = u
End With
End Sub

 

[jake_barnes]

That works great! Thanks much!