Copying multiple columns into a single column

[kavemanperth]

I have text lists in 26 columns on a worksheet and want to copy them all into a single column on another sheet. Each column is different length.
Can someone help me please

 

[Bruno_x]

Try this:

Sub CopyToOneColumn()
For ColNr = 1 To 26
    Range(Cells(1, ColNr), Range(Cells(65536, ColNr).End(xlUp))).Copy _
        Sheets("Blad2").Range("A65536").End(xlUp).Offset(1, 0)
Next
End Sub

 

[kavemanperth]

thanks but I get an error popup 400

 

[Bruno_x]

Sub CopyToOneColumn() 
For ColNr = 1 To 26 
    Range(Cells(1, ColNr), Range(Cells(65536, ColNr).End(xlUp))).Copy _ 
        Sheets("Sheet2").Range("A65536").End(xlUp).Offset(1, 0) 
Next 
End Sub

Edit the sheet-name (Blad2 changed in Sheet2)
Are there empty columns ?

 

[jindon]

Hi,

this is very similer to what I posted the other day

Sub test()
Dim a(), b(), rng As Range, r As Range, dest As Range, i As Integer, ii As Long, iii As Long
Set rng = Application.InputBox("Select Range", Type:=8)
Set dest = Application.InputBox("Select destination cell", Type:=8)
a = rng.Value
ReDim b(1 To rng.Count)
For i = LBound(a, 2) To UBound(a, 2)
    For ii = LBound(a, 1) To UBound(a, 1)
        If a(ii, i) <> "" Then iii = iii + 1: b(iii) = a(ii, i)
    Next
Next
dest.Resize(UBound(b)).Value = Application.Transpose(b)
Erase a, b: Set rng = Nothing: Set dest = Nothing
End Sub

jindon

 

[Fergus]

Hi kaveman,

This is a much more basic code, because I'm not so smart at vba as some of the experts on this Board, but it works for me. If you have more than 1000 rows change the max value of k

Public Sub copytosheet2()
Dim i As Integer, k As Integer, cellcont As Variant, newcont As String
k = 1
Do While k < 1000
    newcont = ""
    i = 1
    Worksheets("Sheet1").Activate
    Do While i < 27
        cellcont = ActiveSheet.Cells(k, i).Value
        newcont = newcont & " " & cellcont
        i = i + 1
    Loop
    newcont = LTrim(newcont)
    If newcont = Empty Then
        Exit Sub
        Else
        Worksheets("Sheet2").Activate
        ActiveSheet.Cells(k, 1).Value = newcont
        k = k + 1
    End If
Loop
End Sub