combining ten columns into one long column

[rfg]

I have ten columns labled pg 1, pg 2 etc...
Each column has about 100 rows.
I need to copy them to a new sheet or workbook into one column putting pg 2 under page 1 to end up with 1 column with about 1000 rows.
I do this every week and the number of pages varies week to week.
Thanks,
Bert

 

[Ekim]

Bert,

Try the following macro.

It does not matter if the columns are not contiguous (the macro will find the data), or the columns are different lenghts, or if there are blank rows in the columns. The macro adds a new worksheet with all data in column A. If combining the data from all columns exceeds 65,536 rows (Excel’s limit) you will get an error message.

Put the macro into a normal module.

Sub OneColumn()
' Jason Morin as amended by Doug Glancy
' http://makeashorterlink.com/?M19F26516
''''''''''''''''''''''''''''''''''''''''''
'Macro to copy columns of variable length
'into 1 continuous column in a new sheet 
''''''''''''''''''''''''''''''''''''''''''

Dim from_lastcol As Long
Dim from_lastrow As Long
Dim to_lastrow As Long
Dim from_colndx As Long
Dim ws_from As Worksheet, ws_to As Worksheet

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

Set ws_from = ActiveWorkbook.ActiveSheet
from_lastcol = ws_from.Cells(1, Columns.Count).End(xlToLeft).Column

'Turn error checking off so if no "AllData" trying to delete doesn't generate Error
On Error Resume Next
'so not prompted to confirm delete
Application.DisplayAlerts = False
'Delete if already exists so don't get error
ActiveWorkbook.Worksheets("AllData").Delete
Application.DisplayAlerts = True
'turn error checking back on
On Error GoTo 0

'since you refer to "AllData" throughout
Set ws_to = Worksheets.Add
ws_to.Name = "AllData"

For from_colndx = 1 To from_lastcol
    from_lastrow = ws_from.Cells(Rows.Count, from_colndx).End(xlUp).Row
    'If you're going to exceed 65536 rows
    If from_lastrow + ws_to.Cells(Rows.Count, 1).End(xlUp).Row <= 65536 Then
        to_lastrow = ws_to.Cells(Rows.Count, 1).End(xlUp).Row
    Else
        MsgBox "This time you've gone to far"
        Exit Sub
    End If
    ws_from.Range(ws_from.Cells(1, from_colndx), ws_from.Cells(from_lastrow, _
      from_colndx)).Copy ws_to.Cells(to_lastrow + 1, 1)
Next

' this deletes any blank rows
ws_to.Columns(1).SpecialCells(xlCellTypeBlanks).EntireRow.Delete

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic 

End Sub

See this line:
ws_from.Range(ws_from.Cells(1, from_colndx), ws_from.Cells(from_lastrow, _

The macro assumes that your data starts in row 1. If you want the macro to start in say row 3, then, in the above line, change Cells(1, from_colndx) to Cells(3, from_colndx).

HTH

Mike

 

[parry]

Hi, this macro may help. Select the cells in question (excluding your header) then run the macro. I have left the first row blank in the new sheet in case you want to put a header in there.

Sub SingleColumn()
Dim CurSh As Worksheet, NewSh As Worksheet, Rng As Range, Col As Long

Set CurSh = ActiveSheet
Set NewSh = Sheets.Add
CurSh.Activate
Set Rng = Application.Intersect(Selection, CurSh.UsedRange)

For Col = 1 To Selection.Columns.Count
Rng.Range(Cells(1, Col), Cells(Rng.Rows.Count, Col)).Copy NewSh.Range("a65536").End(xlUp).Offset(1, 0)
Next Col
End Sub

 

[rfg]

Thanks for the help, they both will work for me.
Bert

 

[aria]

I was looking for a similar answer for the problem I had, thanks very much Ekim!!!

 

[aka_atomix]

Hi, this macro may help. Select the cells in question (excluding your header) then run the macro. I have left the first row blank in the new sheet in case you want to put a header in there.

Sub SingleColumn()
Dim CurSh As Worksheet, NewSh As Worksheet, Rng As Range, Col As Long

Set CurSh = ActiveSheet
Set NewSh = Sheets.Add
CurSh.Activate
Set Rng = Application.Intersect(Selection, CurSh.UsedRange)

For Col = 1 To Selection.Columns.Count
Rng.Range(Cells(1, Col), Cells(Rng.Rows.Count, Col)).Copy NewSh.Range("a65536").End(xlUp).Offset(1, 0)
Next Col
End Sub

This is almost exactly what I need. The only problem is it is copying formulas instead of just the values. Anyone know how to set this to only copy cell values?

 

[DeonM]

Hello

This is a very old thread but perhaps someone can help.

Is there a line one can add to this macro will make it only paste cells if they are not blank.

I am copying a range of values spread across approx 300 lines and 125 columns, of which 60% of the cells are blank i.e. each row is has some values, but some rows only in Column A and some rows have values up to column DR.

This macro leaves all the blank cells in column A. Of course one can easily manually fix it by sorting or filtering afterwards, but maybe the fix in the macro is simple?


(I'm not sure if the line:

' this deletes any blank rows
ws_to.Columns(1).SpecialCells(xlCellTypeBlanks).EntireRow.Delete

is supposed to address this, but it does not achieve it.)

Deon

 

[tajikidc]

Mike.. this is fantastic! I have a couple questions.

1. Is there any way to combine only 1 single desired column from multiple worksheets...say column D of both worksheets 1 and 2 into the combined "AllData" worksheet?

2. Is it possible to invoke this script via an active X checkbox?

Bert,

Try the following macro.

It does not matter if the columns are not contiguous (the macro will find the data), or the columns are different lenghts, or if there are blank rows in the columns. The macro adds a new worksheet with all data in column A. If combining the data from all columns exceeds 65,536 rows (Excel’s limit) you will get an error message.

Put the macro into a normal module.

Sub OneColumn()
' Jason Morin as amended by Doug Glancy
' http://makeashorterlink.com/?M19F26516
''''''''''''''''''''''''''''''''''''''''''
'Macro to copy columns of variable length
'into 1 continuous column in a new sheet 
''''''''''''''''''''''''''''''''''''''''''

Dim from_lastcol As Long
Dim from_lastrow As Long
Dim to_lastrow As Long
Dim from_colndx As Long
Dim ws_from As Worksheet, ws_to As Worksheet

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

Set ws_from = ActiveWorkbook.ActiveSheet
from_lastcol = ws_from.Cells(1, Columns.Count).End(xlToLeft).Column

'Turn error checking off so if no "AllData" trying to delete doesn't generate Error
On Error Resume Next
'so not prompted to confirm delete
Application.DisplayAlerts = False
'Delete if already exists so don't get error
ActiveWorkbook.Worksheets("AllData").Delete
Application.DisplayAlerts = True
'turn error checking back on
On Error GoTo 0

'since you refer to "AllData" throughout
Set ws_to = Worksheets.Add
ws_to.Name = "AllData"

For from_colndx = 1 To from_lastcol
    from_lastrow = ws_from.Cells(Rows.Count, from_colndx).End(xlUp).Row
    'If you're going to exceed 65536 rows
    If from_lastrow + ws_to.Cells(Rows.Count, 1).End(xlUp).Row <= 65536 Then
        to_lastrow = ws_to.Cells(Rows.Count, 1).End(xlUp).Row
    Else
        MsgBox "This time you've gone to far"
        Exit Sub
    End If
    ws_from.Range(ws_from.Cells(1, from_colndx), ws_from.Cells(from_lastrow, _
      from_colndx)).Copy ws_to.Cells(to_lastrow + 1, 1)
Next

' this deletes any blank rows
ws_to.Columns(1).SpecialCells(xlCellTypeBlanks).EntireRow.Delete

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic 

End Sub

See this line:
ws_from.Range(ws_from.Cells(1, from_colndx), ws_from.Cells(from_lastrow, _

The macro assumes that your data starts in row 1. If you want the macro to start in say row 3, then, in the above line, change Cells(1, from_colndx) to Cells(3, from_colndx).

HTH

Mike