Combine several columns of different length into one single column

[Guest]

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 simila
http://groups.google.com/group/micr...author:Herbert+author:Seidenberg&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

 

[Norman Jones]

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
'<<================

 

[Norman Jones]

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.

 

[Norman Jones]

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
'<<================

 

[Norman Jones]

Hi Neil,

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

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
'<<================

 

[Guest]

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!

Hi Neil,

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

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
'<<================