Sub MergeCxC()
   '-- Merge cells in multiple selected areas Column by Column ---
   '    limited to the usedrange  (Ctrl+End)
   ' D.McRitchie, 2002-05-31 in merge.htm
  Dim rng As Range
  Dim rw As Range, ix As Long
  Set rng = Intersect(Selection, ActiveSheet.UsedRange)
  If rng Is Nothing Then
     MsgBox "nothing in usedrange to be merged"
     GoTo done
  End If
  Dim i As Long, j As Long
  For i = 1 To Selection.Areas.Count
      For j = 1 To Selection.Areas(i).Columns.Count
        Application.DisplayAlerts = False
        Selection.Areas(i).Columns(j).MergeCells = True
        Application.DisplayAlerts = True
      Next
  Next
done:
End Sub

http://www.mvps.org/dmcritchie/excel/merge.htm

Merge cells in multiple selected areas Column by Column

Visual Basic