Is preferable to work with large blocks of cells to avoid those many loops.
Copy and paste the code below in a standar code module and run
"VerticalValues" proc.
'-----------------------------8<----------------------------------------
Option Explicit
Sub VerticalValues()
Dim rngS As Range
Dim rngT As Range
On Error Resume Next
Set rngS = Application.InputBox(prompt:= _
"Select source range.", Default:=Selection.Address, Type:=8)
If Not rngS Is Nothing Then
Set rngT = Application.InputBox(prompt:= _
"Select destination cell.", Default:=Selection.Address,
Type:=8)
On Error GoTo 0
If Not rngT Is Nothing Then
Call ValuesInColumn(rngS, rngT)
End If
End If
End Sub
Sub ValuesInColumn(ByVal rngSource As Range, ByVal rngTarget As Range)
Dim rngConstants As Range
Dim rngArea As Range
Dim rngCol As Range
Dim lngCells As Long
With rngSource
On Error Resume Next
Set rngSource = .SpecialCells(xlCellTypeFormulas, 1)
Set rngConstants = .SpecialCells(xlCellTypeConstants, 1)
If Not rngSource Is Nothing Then
Set rngSource = Application.Union(rngSource, rngConstants)
Else
Set rngSource = rngConstants
End If
On Error GoTo 0
End With
If Not rngSource Is Nothing Then
If rngSource.Count < Rows.Count Then
With rngTarget.Range("A1")
For Each rngArea In rngSource.Areas
For Each rngCol In rngArea.Columns
.Cells(lngCells + 1).Resize(rngCol.Cells.Count) = _
rngCol.Cells.Value
lngCells = lngCells + rngCol.Cells.Count
Next rngCol
Next rngArea
End With
Else
MsgBox "Too many cells!", vbExclamation
End If
Else
MsgBox "No cells were found!", vbExclamation
End If
End Sub
'-----------------------------8<----------------------------------------
John
Ο χÏήστης "joel" ÎγγÏαψε:
