Multiple Columns to Single Columns

S

simonfunston

Hi Guys,

I have a spreadsheet which has data in a number of columns which I need
to copy to another sheet in one single column.

What I need to be able to do is select all the columns from the source
sheet (this number may vary), and then have select a start point in
another sheet and ahve all the columns sequentially pasted in.

I've started to write a macro to do this but haven't got very far, can
any help me out?

Thanks

Simon
 
T

Toppers

Try:

Sub CopyAndMerge()

Dim inrange As Range, outrange As Range
Dim cValue as variant
Dim r as long, c as integer

Set inrange = Application.InputBox(prompt:="Select Input range", Type:=8)
Set outrange = Application.InputBox(prompt:="Select Output range", Type:=8)

Do While Application.Or(outrange.Rows.Count <> 1, outrange.Columns.Count <> 1)
MsgBox "Output range must be a single cell"
Set outrange = Application.InputBox(prompt:="Select Output range", Type:=8)
Loop

For r = 1 To inrange.Rows.Count

Cvalue = ""
For c = 1 To inrange.Columns.Count
Cvalue = Cvalue & inrange(r, c).Value
Next c

outrange.Value = Cvalue

Set outrange = outrange.Offset(1, 0)
Next r
End Sub

HTH
 
G

Gord Dibben

Sub OneColumnV2()
''''''''''''''''''''''''''''''''''''''''''
'Macro to copy columns of variable length'
'into 1 continous column in a new sheet '
'Modified 17 FEb 2006 by BD
''''''''''''''''''''''''''''''''''''''''''
Dim iLastcol As Long
Dim iLastRow As Long
Dim jLastrow As Long
Dim ColNdx As Long
Dim Ws As Worksheet
Dim myRng As Range
Dim ExcludeBlanks As Boolean
Dim mycell As Range

ExcludeBlanks = (MsgBox("Exclude Blanks", vbYesNo) = vbYes)
Set Ws = ActiveSheet
iLastcol = Ws.Cells(1, Ws.Columns.Count).End(xlToLeft).Column
On Error Resume Next

Application.DisplayAlerts = False
Worksheets("Alldata").Delete
Application.DisplayAlerts = True

Sheets.Add.Name = "Alldata"

For ColNdx = 1 To iLastcol

iLastRow = Ws.Cells(Ws.Rows.Count, ColNdx).End(xlUp).Row

Set myRng = Ws.Range(Ws.Cells(1, ColNdx), _
Ws.Cells(iLastRow, ColNdx))

If ExcludeBlanks Then
For Each mycell In myRng
If mycell.Value <> "" Then
jLastrow = Sheets("Alldata").Cells(Rows.Count, 1) _
.End(xlUp).Row
mycell.Copy
Sheets("Alldata").Cells(jLastrow + 1, 1) _
.PasteSpecial xlPasteValues
End If
Next mycell
Else
myRng.Copy
jLastrow = Sheets("Alldata").Cells(Rows.Count, 1) _
.End(xlUp).Row
mycell.Copy
Sheets("Alldata").Cells(jLastrow + 1, 1) _
.PasteSpecial xlPasteValues
End If
Next

Sheets("Alldata").Rows("1:1").EntireRow.Delete

Ws.Activate
End Sub


Gord Dibben MS Excel MVP
 
T

Toppers

...misread your post .....try this:

Sub CopyAndMerge()

Dim inrange As Range, outrange As Range
Dim cValue As Variant
Dim r As Long, c As Integer


Set inrange = Application.InputBox(prompt:="Select Input range", Type:=8)
Set outrange = Application.InputBox(prompt:="Select Output range", Type:=8)


Do While Application.Or(outrange.Rows.Count <> 1, outrange.Columns.Count <> 1)
MsgBox "Output range must be a single cell"
Set outrange = Application.InputBox(prompt:="Select Output range", Type:=8)
Loop


For r = 1 To inrange.Rows.Count

For c = 1 To inrange.Columns.Count
outrange.Value = inrange(r, c).Value
Set outrange = outrange.Offset(1, 0)
Next c

Next r
End Sub
 
Top