reposting: combining multiple columns into one column - enhancements

[markx]

Hello everybody,

I repost the message from "excel.worksheet.functions" forum, maybe it was
not appropriate for the questions I had (or maybe it was too complicated)...
-----------------
-----------------
I've found (on one of the excel newsgroups) a macro "combining multiple
columns into one column", apparently posted initially by Dave Peterson or
Bob Phillips.

The macro makes - for sure - the basic work, however I would be glad if
someone could help me to add 3 enhancements:

1st: my initial page contains formulas, so I would need to convert these
data into "paste special/values" (if not, the data is not copied properly).

2nd: I've noticed that when I use "ctrl + down arrow" on the columns, il
goes further than the last cell with value (in fact, it goes always until
the row 143, probably because the formula is extended until this row, even
if it returns blank cells), so it would be great if this could also be
resolved somehow... , because without this, there will be a lot of "free"
space between the "real" end of one column and the start of the next one...

3rd: some columns contain blank cells in the middle: what should I add to
the code (optionally) if I want to elimitate all the blank cells in the new,
combined, column?

Many thanks for your help on this...
Mark

=============================
Sub OneColumn()

''''''''''''''''''''''''''''''''''''''''''
'Macro to copy columns of variable length'
'into 1 continous column in a new sheet '
''''''''''''''''''''''''''''''''''''''''''
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 idx As Integer

Set ws = ActiveWorkbook.ActiveSheet
ilastcol = Cells(1, Columns.Count).End(xlToLeft).Column

With Sheets.Add
.Name = "Alldata"
End With

idx = Sheets("Alldata").Index
Sheets(idx + 1).Activate

For colndx = 1 To ilastcol

ilastrow = ws.Cells(Rows.Count, colndx).End(xlUp).Row
jlastrow = Sheets("Alldata").Cells(Rows.Count, 1) _
.End(xlUp).Row

Set myRng = Range(Cells(1, colndx), _
Cells(ilastrow, colndx))
With myRng
.Copy Sheets("Alldata").Cells(jlastrow + 1, 1)
End With
Next

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

End Sub

 

[Bernie Deitrick]

Try the version below.

HTH,
Bernie
MS Excel MVP

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