Combine several columns of different length into one single column

Hi! I have columns A to J, all with a different number of entries (this will
vary with time, but they will never have the same number each). I need a
macro to take all the data from each of these columns (ignoring blanks) and
put it all into column K, so that cells K1:K... contain all the data of the
other columns combined.

I do, however, need to keep the original data in their columns too, so it
would need to be copying the data rather than moving it.

I did find a webpage which seemed to do similar
http://groups.google.com/group/micro...g&rnum=1&hl=en

but Gord Dibbin's macro put the newly formed column on a new sheet. I would
need it to be column K of the same sheet. I would also need it to be able to
redo it (this code restricted it to being used once, since it could not
create a new sheet of the same name twice).

If anybody could help I'd be very grateful. For some annoying reason my
browser kept crashing whenever I tried the relevant search terms on this site.

Many thanks in advance, Neil

Hi Neil,

Try:

'================>>
Public Sub Tester001()
Dim WB As Workbook
Dim SH As Worksheet
Dim rng As Range
Dim srcRng As Range
Dim destRng As Range
Dim rcell As Range
Dim col As Range
Dim LastRow As Long

Set WB = Workbooks("YourBook.xls") '<<===== CHANGE
Set SH = WB.Sheets("Sheet2") '<<===== CHANGE
Set rng = SH.Range("A:J")

With SH
.Columns("F:F").ClearContents
For Each col In rng.Columns
LastRow = .Cells(Rows.Count, col.Column).End(xlUp).Row
Set srcRng = col.Cells(1).Resize(LastRow)
Set destRng = IIf(Application.CountA(.Range("K:K")) = 0, _
.Range("K1"), .Cells(Rows.Count, "K").End(xlUp)(2))
destRng.Select
srcRng.Copy Destination:=destRng
Next col
End With

End Sub
'<<================


---
Regards,
Norman


"Neil Goldwasser" <[email protected]> wrote in
message news:[email protected]...
> Hi! I have columns A to J, all with a different number of entries (this
> will
> vary with time, but they will never have the same number each). I need a
> macro to take all the data from each of these columns (ignoring blanks)
> and
> put it all into column K, so that cells K1:K... contain all the data of
> the
> other columns combined.
>
> I do, however, need to keep the original data in their columns too, so it
> would need to be copying the data rather than moving it.
>
> I did find a webpage which seemed to do similar
> http://groups.google.com/group/micro...g&rnum=1&hl=en
>
> but Gord Dibbin's macro put the newly formed column on a new sheet. I
> would
> need it to be column K of the same sheet. I would also need it to be able
> to
> redo it (this code restricted it to being used once, since it could not
> create a new sheet of the same name twice).
>
> If anybody could help I'd be very grateful. For some annoying reason my
> browser kept crashing whenever I tried the relevant search terms on this
> site.
>
> Many thanks in advance, Neil

Hi Neil,

There are two minor amendements:

Delete

> Dim rcell As Range

and delete

> destRng.Select

The first is simply an unused variable and the latter was only included for
test purposes.


---
Regards,
Norman

Hi Neil,

Taking the opportunity to correct a typo, try instead:

'================>>
Public Sub Tester001()
Dim WB As Workbook
Dim SH As Worksheet
Dim rng As Range
Dim srcRng As Range
Dim destRng As Range
Dim rcell As Range
Dim col As Range
Dim LastRow As Long

Set WB = Workbooks("YourBook.xls") '<<===== CHANGE
Set SH = WB.Sheets("Sheet2") '<<===== CHANGE
Set rng = SH.Range("A:J")

With SH
.Columns("K:K").ClearContents '<< ==== Typo corrected
For Each col In rng.Columns
LastRow = .Cells(Rows.Count, col.Column).End(xlUp).Row
Set srcRng = col.Cells(1).Resize(LastRow)
Set destRng = IIf(IsEmpty(Range("K1")), .Range("K1"), _
.Cells(Rows.Count, "K").End(xlUp)(2))
destRng.Select
srcRng.Copy Destination:=destRng
Next col
End With

End Sub
'<<================


---
Regards,
Norman

Hi Neil,

Re-reading your post, I see that I have overlooked your requirement:

>> (ignoring blanks)

Therefore, please replace my suggested code with the following version:

'================>>
Public Sub Tester001()
Dim WB As Workbook
Dim SH As Worksheet
Dim rng As Range
Dim srcRng As Range
Dim destRng As Range
Dim col As Range
Dim LastRow As Long

Set WB = Workbooks("YourBook.xls") '<<===== CHANGE
Set SH = WB.Sheets("Sheet2") '<<===== CHANGE
Set rng = SH.Range("A:J")

With SH
.Columns("K:K").ClearContents
For Each col In rng.Columns
LastRow = .Cells(Rows.Count, col.Column).End(xlUp).Row
Set srcRng = col.Cells(1).Resize(LastRow)
Set destRng = IIf(IsEmpty(Range("K1")), .Range("K1"), _
.Cells(Rows.Count, "K").End(xlUp)(2))
destRng.Select
srcRng.Copy Destination:=destRng
Next col

On Error Resume Next
Range("K:K").SpecialCells(xlBlanks).Delete Shift:=xlUp
On Error GoTo 0

End With

End Sub
'<<================


---
Regards,
Norman



"Norman Jones" <[email protected]> wrote in message
news:[email protected]...
> Hi Neil,
>
> Taking the opportunity to correct a typo, try instead:
>
> '================>>
> Public Sub Tester001()
> Dim WB As Workbook
> Dim SH As Worksheet
> Dim rng As Range
> Dim srcRng As Range
> Dim destRng As Range
> Dim rcell As Range
> Dim col As Range
> Dim LastRow As Long
>
> Set WB = Workbooks("YourBook.xls") '<<===== CHANGE
> Set SH = WB.Sheets("Sheet2") '<<===== CHANGE
> Set rng = SH.Range("A:J")
>
> With SH
> .Columns("K:K").ClearContents '<< ==== Typo corrected
> For Each col In rng.Columns
> LastRow = .Cells(Rows.Count, col.Column).End(xlUp).Row
> Set srcRng = col.Cells(1).Resize(LastRow)
> Set destRng = IIf(IsEmpty(Range("K1")), .Range("K1"), _
> .Cells(Rows.Count, "K").End(xlUp)(2))
> destRng.Select
> srcRng.Copy Destination:=destRng
> Next col
> End With
>
> End Sub
> '<<================
>
>
> ---
> Regards,
> Norman
>

Thank you very much for your help Norman, it is much appreciated!

And for anybody else who may be browsing the NG for advice on this matter,
Norman very kindly provided me with an updated code, which ensures that the
results are exactly the same either when the initial columns are headed by
blank cells, or when headed by cells containing data. It also ensures that
column K retains its original interior colour (please note that it now
functions on the active sheet):

'================>>
Public Sub Tester001A()
Dim SH As Worksheet
Dim rng As Range
Dim srcRng As Range
Dim destRng As Range
Dim col As Range
Dim LastRow As Long
Dim iColour As Long 'NEW VARIABLE

Set SH = ActiveSheet
Set rng = SH.Range("A:J")

With SH
iColour = .Cells(1, "K").Interior.ColorIndex ''NEW CODE LINE
.Columns("K:K").ClearContents
For Each col In rng.Columns
LastRow = .Cells(Rows.Count, col.Column).End(xlUp).Row
Set srcRng = col.Cells(1).Resize(LastRow)
Set destRng = .Cells(Rows.Count, "K").End(xlUp)(2)
srcRng.Copy Destination:=destRng
Next col

On Error Resume Next
Range("K:K").SpecialCells(xlBlanks).Delete Shift:=xlUp
On Error GoTo 0

'NEW CODE LINE
Intersect(.Range("K:K"), .UsedRange).Interior.ColorIndex = iColour

End With

End Sub
'<<================

I cannot stress enough how useful this code has been, thanks again Norman!




"Norman Jones" wrote:

> Hi Neil,
>
> Re-reading your post, I see that I have overlooked your requirement:
>
> >> (ignoring blanks)
>
> Therefore, please replace my suggested code with the following version:
>
> '================>>
> Public Sub Tester001()
> Dim WB As Workbook
> Dim SH As Worksheet
> Dim rng As Range
> Dim srcRng As Range
> Dim destRng As Range
> Dim col As Range
> Dim LastRow As Long
>
> Set WB = Workbooks("YourBook.xls") '<<===== CHANGE
> Set SH = WB.Sheets("Sheet2") '<<===== CHANGE
> Set rng = SH.Range("A:J")
>
> With SH
> .Columns("K:K").ClearContents
> For Each col In rng.Columns
> LastRow = .Cells(Rows.Count, col.Column).End(xlUp).Row
> Set srcRng = col.Cells(1).Resize(LastRow)
> Set destRng = IIf(IsEmpty(Range("K1")), .Range("K1"), _
> .Cells(Rows.Count, "K").End(xlUp)(2))
> destRng.Select
> srcRng.Copy Destination:=destRng
> Next col
>
> On Error Resume Next
> Range("K:K").SpecialCells(xlBlanks).Delete Shift:=xlUp
> On Error GoTo 0
>
> End With
>
> End Sub
> '<<================
>
>
> ---
> Regards,
> Norman
>
>
>
> "Norman Jones" <[email protected]> wrote in message
> news:[email protected]...
> > Hi Neil,
> >
> > Taking the opportunity to correct a typo, try instead:
> >
> > '================>>
> > Public Sub Tester001()
> > Dim WB As Workbook
> > Dim SH As Worksheet
> > Dim rng As Range
> > Dim srcRng As Range
> > Dim destRng As Range
> > Dim rcell As Range
> > Dim col As Range
> > Dim LastRow As Long
> >
> > Set WB = Workbooks("YourBook.xls") '<<===== CHANGE
> > Set SH = WB.Sheets("Sheet2") '<<===== CHANGE
> > Set rng = SH.Range("A:J")
> >
> > With SH
> > .Columns("K:K").ClearContents '<< ==== Typo corrected
> > For Each col In rng.Columns
> > LastRow = .Cells(Rows.Count, col.Column).End(xlUp).Row
> > Set srcRng = col.Cells(1).Resize(LastRow)
> > Set destRng = IIf(IsEmpty(Range("K1")), .Range("K1"), _
> > .Cells(Rows.Count, "K").End(xlUp)(2))
> > destRng.Select
> > srcRng.Copy Destination:=destRng
> > Next col
> > End With
> >
> > End Sub
> > '<<================
> >
> >
> > ---
> > Regards,
> > Norman
> >
>
>
>