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" wrote in message
...
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