Option Explicit
'David McRitchie, http://www.mvps.org/dmcritchie/code/merge.txt 2002-05-31 updated 2002-12-16
 
Sub MergeRxR()
   '-- Merge cells in multiple selected areas Row by Row  ---
   '    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).Rows.Count
        Application.DisplayAlerts = False
        Selection.Areas(i).Rows(j).MergeCells = True
        Application.DisplayAlerts = True
      Next
  Next
done:
End Sub
Sub MergeRxR_Join()
   '-- Merge cells in multiple selected areas Row by Row  ---
   '    limited to the usedrange  (Ctrl+End)
   ' D.McRitchie, 2002-05-31 in merge.htm
  Dim str As String, ii As Long
  str = ""
  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).Rows.Count
        Application.DisplayAlerts = False
        str = ""   '... concatenate cells for this row in selection
        For ii = 1 To Selection.Areas(i).Rows(j).Columns.Count
          str = str & " " & Selection.Areas(i).Rows(j).Columns(ii)
        Next ii
        str = Mid(str, 2)
        Selection.Areas(i).Rows(j)(1) = str
        Selection.Areas(i).Rows(j).MergeCells = True
        Application.DisplayAlerts = True
      Next
  Next
done:
End Sub

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
 
Sub UnMergeSelected()
   '-- same as  format, cells, alignment (tab),  (turn off) Merge Cells
   Selection.MergeCells = False
End Sub

Sub SetupG20()
   Cells.MergeCells = False
   Range("A1:G20").Select
   Application.Run "personal.xls!MarkCells"  'see join.htm / merge.htm
End Sub


Sub Joiner()
   '-- Merge cells in multiple selected areas into the
   '--  the first cell of each area
   '--  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, k As Long
  Dim newStr As String
  Dim cell As Range
  Dim cellRng As Range
  For i = 1 To Selection.Areas.Count
    '--MsgBox "area " & i & " of " & Selection.Areas.Count
    For j = 1 To Selection.Areas(i).Columns.Count
      newStr = ""
      For k = 1 To Selection.Areas(i).Rows.Count
         '--MsgBox Selection.Areas(i).Cells(k, j).Address(0, 0)
         If Trim(Selection.Areas(i).Cells(k, j).Value) <> "" Then
           newStr = newStr & vbLf & Selection.Areas(i).Cells(k, j).Value
           Selection.Areas(i).Cells(k, j) = ""
         End If
      Next k
      newStr = Trim(newStr)
      If newStr <> "" Then Selection.Areas(i).Cells(1, j) = Trim(newStr)
    Next j
  Next i
done:
End Sub

Sub Merge_On_C_equal()
  'David McRitchie, 2002-12-16, misc
  '  If D is empty and C matches C above then
  '  merge  E and F with row above and delete
  '  current row.  Always start from bottom when
  '  inserting/deleting rows to keep things simple.
    Application.ScreenUpdating = False
    Application.Calculation = xlManual   '--Excel 95

    'suggest selecting all cells for this...
    Cells.Select

    Dim Rcnt As Long, Ccnt As Long, r As Long, c As Long
    Dim CurrCell As Range
    On Error Resume Next
    Selection.Replace What:=Chr(160), Replacement:=Chr(32), _
        LookAt:=xlPart, SearchOrder:=xlByColumns, MatchCase:=True
    Rcnt = Cells.SpecialCells(xlLastCell).Row
    Ccnt = Cells.SpecialCells(xlLastCell).Column
    For r = Rcnt To 2 Step -1
       If IsEmpty(Cells(r, 4)) And _
        cells(r,3).value <> ""  and _
        Cells(r, 3).Value = Cells(r - 1, 3).Value Then
          For c = 4 To Ccnt
             if Cells(r,c) <> "" then _
                Cells(r - 1, c) = Cells(r - 1, c) & Chr(10) & Cells(r, c)
          Next c
          Cells(r, 1).EntireRow.Delete
       End If
    Next r
    Application.Calculation = xlAutomatic  '--Excel 95
    Application.ScreenUpdating = True
  End Sub