OpenOffice.cz - web věnovaný kancelářským balíkům OpenOffice.org

Option Explicit
'David McRitchie, http://www.mvps.org/dmcritchie/code/merge.txt 2002-05-31

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)
    '   JOIN contents of cells before merging
   ' 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
End Sub

Sub MergeEmpty_A()
'David McRitchie, 2004-05-27, programming
    With Cells
        .HorizontalAlignment = xlGeneral
        .VerticalAlignment = xlTop
    End With
    On Error GoTo done
    Cells(Rows.Count, 2).End(xlUp).Activate
    ActiveCell.Offset(0, -1).Activate
backthere:
    Range(ActiveCell.Address, _
       ActiveCell.End(xlUp).Address).Select
    Selection.Merge
    ActiveCell.Offset(-1, 0).Activate
    GoTo backthere
done:
End Sub