Vba excel снять объединение ячеек на листе

А ведь тема-то интересная, часто нужная и так и не доведенная до ума…  
Вот есть, например, таблица — штатное расписание организации (ну, или табличное описание чего угодно, имеющего иерархическую структуру) составленное с использованием объединенных ячеек. Естественно, что из-за наличия объединенных ячеек такую таблицу нормально фильтровать будет невозможно, а уж о том, чтобы перенести информацию в базу данных даже и подумать страшно…  
Макрос типа:  

  Sub UnMerge_And_Fill_All()  
  Dim MainValue  
  Dim iCell As Range  
  MainValue = Selection.Value  
  Selection.UnMerge  
  For Each iCell In Selection  
     iCell.Value = MainValue  
  Next  
End Sub  

  при выделении по очереди каждой из объединенных ячеек всё делает правильно.  
Но если выделить диапазон, содержащий несколько групп объединенных ячеек, то после разъединения все ячейки выделенного диапазона окажутся заполнены значением MainValue.  
А надо сделать чтобы в выделенном диапазоне перебирались в цикле все группы объединенных ячеек, каждая группа разгруппировывалась и её ячейкам присваивалось своё значение MainValue  
Алгоритм-то мне ясен, но как сделать, что-то не пойму…  
В приведенном примере на Лист1 в ячейках A1:E40 (в общем случае A:E) показана исходная таблица, а на Лист2 — таблица, как она должна выглядеть после разгруппировки макросом Smart_UnMerge

С уважением, Алексей (ИМХО: Excel-2003 — THE BEST!!!)
<#0>

Что-то у меня не работает…  
Ругается «Недопустимое число аргументов или присвоение значения свойства.  

  Т.к. после iCell.UnMerge изначальное Selection сбрасывается и выбранными оказываются разгруппированные ячейки, то пришлось его запоминать в дополнительной переменной Sel_0  

  Сделал так:  
Sub Smart_UnMerge()  
  Dim MainValue  
  Dim iCell As Range  
  Dim iiCell As Range  
  Dim Sel_0  
  Sel_0 = Selection.Range  
  For Each iCell In Sel_0  
     If iCell.MergeCells = True Then  
        MainValue = iCell.Value  
        iCell.UnMerge  
        For Each iiCell In Selection  
           iiCell.Value = MainValue  
        Next  
     End If  
  Next  
End Sub

С уважением, Алексей (ИМХО: Excel-2003 — THE BEST!!!)
<#0>

С уважением, Алексей (ИМХО: Excel-2003 — THE BEST!!!)
<#0>

С уважением, Алексей (ИМХО: Excel-2003 — THE BEST!!!)
<#0>

С уважением, Алексей (ИМХО: Excel-2003 — THE BEST!!!)
<#0>

С уважением, Алексей (ИМХО: Excel-2003 — THE BEST!!!)
<#0>

С уважением, Алексей (ИМХО: Excel-2003 — THE BEST!!!)
<#0>

на всякий случай если кому-нибудь надо:  
Sub UnMerge_and_Fill_by_Value()  
  ‘—————————————————————————————  
  ‘ Procedure : UnMerge_and_Fill_by_Value  
  ‘ Author    : The_Prist (

http://www.planetaexcel.ru/forum.php?thread_id=3760&thread_id=3760&page_forum=lastpage&allnum_forum=14#post86381

)  
  ‘ Date      : 23.12.2009  
  ‘ Purpose   : Снимает объединение со всех ячеек выделенного диапазона _  
    и заполняет все разгруппированные ячейки каждой бывшей группы значениями верхней левой  
  ‘—————————————————————————————  
  Dim sValue As String, sAddress As String  
  Dim rRange As Range, rCell As Range  
  Application.ScreenUpdating = False  
  Set rRange = Range(Cells(Selection.Row, Selection.Column), _  
                     Cells(Cells.SpecialCells(xlLastCell).Row, _  
                           Selection.Column + Selection.Columns.Count — 1))  
  For Each rCell In rRange  
     If rCell.MergeCells = True Then  
        sValue = rCell.Value: sAddress = rCell.MergeArea.Address  
        rCell.UnMerge: Range(sAddress).Value = rCell.Value  
     End If  
  Next  
  Application.ScreenUpdating = True  
End Sub  

  Sub UnMerge_and_Fill_by_HyperLink()  
  ‘—————————————————————————————  
  ‘ Procedure : UnMerge_and_Fill_by_HyperLink  
  ‘ Author    : The_Prist (

http://www.planetaexcel.ru/forum.php?thread_id=3760&thread_id=3760&page_forum=lastpage&allnum_forum=14#post86381

)  
  ‘ Date      : 23.12.2009  
  ‘ Purpose   : Снимает объединение со всех ячеек выделенного диапазона _  
    и заполняет все разгруппированные ячейки каждой бывшей группы ссылками на значения верхней левой  
  ‘—————————————————————————————  
  Dim sAddress As String  
  Dim rRange As Range, rCell As Range, rEmptyRange As Range  
  Dim lLastRow As Long, lLastCol As Long  
  lLastRow = Cells.SpecialCells(xlLastCell).Row  
  lLastCol = Selection.Column + Selection.Columns.Count — 1  
  If lLastRow > Selection.Row + Selection.Rows.Count — 1 Then lLastRow = Selection.Row + Selection.Rows.Count — 1  
  Application.ScreenUpdating = False  
  Set rRange = Range(Cells(Selection.Row, Selection.Column), Cells(lLastRow, lLastCol))  
  For Each rCell In rRange  
     If rCell.MergeCells = True Then  
        sAddress = rCell.MergeArea.Address: rCell.UnMerge  
        On Error Resume Next: Set rEmptyRange = Range(sAddress).SpecialCells(xlCellTypeBlanks)  
        If Not rEmptyRange Is Nothing Then rEmptyRange.Formula = «=» & rCell.Cells(1).Address  
     End If  
  Next  
  Set rRange = Nothing: Set rCell = Nothing: Set rEmptyRange = Nothing  
  Application.ScreenUpdating = True  
End Sub

С уважением, Алексей (ИМХО: Excel-2003 — THE BEST!!!)
<#0>

Пардон, не углядел небольшую неточность…  
Диапазон выделения не ограничивается Selection  
Естественно, должно быть так:  

  Sub UnMerge_and_Fill_by_Value()  
‘—————————————————————————————  
‘ Procedure : UnMerge_and_Fill_by_Value  
‘ Author : The_Prist (

http://www.planetaexcel.ru/forum.php?thread_id=3760&thread_id=3760&page_forum=lastpage&allnum_forum=14#post86381

)  
‘ Date : 23.12.2009  
‘ Purpose : Снимает объединение со всех ячеек выделенного диапазона _  
и заполняет все разгруппированные ячейки каждой бывшей группы значениями верхней левой  
‘—————————————————————————————  
Dim sValue As String, sAddress As String  
Dim rRange As Range, rCell As Range  
Application.ScreenUpdating = False  
Set rRange = Intersect(Selection, Range(Cells(Selection.Row, Selection.Column), _  
Cells(Cells.SpecialCells(xlLastCell).Row, _  
Selection.Column + Selection.Columns.Count — 1)))  
For Each rCell In rRange  
If rCell.MergeCells = True Then  
sValue = rCell.Value: sAddress = rCell.MergeArea.Address  
rCell.UnMerge: Range(sAddress).Value = rCell.Value  
End If  
Next  
Application.ScreenUpdating = True  
End Sub  

  Sub UnMerge_and_Fill_by_HyperLink()  
‘—————————————————————————————  
‘ Procedure : UnMerge_and_Fill_by_HyperLink  
‘ Author : The_Prist (

http://www.planetaexcel.ru/forum.php?thread_id=3760&thread_id=3760&page_forum=lastpage&allnum_forum=14#post86381

)  
‘ Date : 23.12.2009  
‘ Purpose : Снимает объединение со всех ячеек выделенного диапазона _  
и заполняет все разгруппированные ячейки каждой бывшей группы ссылками на значения верхней левой  
‘—————————————————————————————  
Dim sAddress As String  
Dim rRange As Range, rCell As Range, rEmptyRange As Range  
Dim lLastRow As Long, lLastCol As Long  
lLastRow = Cells.SpecialCells(xlLastCell).Row  
lLastCol = Selection.Column + Selection.Columns.Count — 1  
If lLastRow > Selection.Row + Selection.Rows.Count — 1 Then lLastRow = Selection.Row + Selection.Rows.Count — 1  
Application.ScreenUpdating = False  
Set rRange = Intersect(Selection, Range(Cells(Selection.Row, Selection.Column), Cells(lLastRow, lLastCol)))  
For Each rCell In rRange  
If rCell.MergeCells = True Then  
sAddress = rCell.MergeArea.Address: rCell.UnMerge  
On Error Resume Next: Set rEmptyRange = Range(sAddress).SpecialCells(xlCellTypeBlanks)  
If Not rEmptyRange Is Nothing Then rEmptyRange.Formula = «=» & rCell.Cells(1).Address  
End If  
Next  
Set rRange = Nothing: Set rCell = Nothing: Set rEmptyRange = Nothing  
Application.ScreenUpdating = True  
End Sub

С уважением, Алексей (ИМХО: Excel-2003 — THE BEST!!!)
<#0>

Разбирался с кучей макросов в своём Personal.xls, немного «причесал» и слепил в один два предыдущих макроса заполнения разгруппированных ячеек:  
Sub UnMerge_and_Fill()  
  ‘—————————————————————————————  
  ‘ Procedure    : UnMerge_and_Fill  
  ‘ Topic_HEADER : Снятие объединения ячеек с заполнением  
  ‘ Topic_URL    :

http://www.planetaexcel.ru/forum.php?thread_id=3760  

  ‘ Purpose      : Снимает объединение со всех ячеек выделенного диапазона  
  ‘                и заполняет все разгруппированные ячейки КАЖДОЙ бывшей группы  
  ‘                либо ссылками на значения верхней левой, либо её значениями  
  ‘—————————————————————————————  
  If Selection.Cells.Count <= 1 Then Exit Sub  
  Dim rRange As Range, rCell As Range, sValue$, sAddress$, i&  
  Application.ScreenUpdating = False  
  Set rRange = Intersect(Selection, ActiveSheet.UsedRange)  
  Select Case MsgBox(«»»ДА»» — заполнить ячейки формулами-ссылками на первую ячейку» & vbCrLf & _  
                     «»»НЕТ»» — заполнить ячейки значениями из первой ячейки» & vbCrLf & _  
                     «»»ОТМЕНА»» не разгруппировывать» _  
                     , vbYesNoCancel + vbQuestion, «Как заполнять ячейки после разгруппировки?»)  
     Case vbYes   ‘ разгруппировать все ячейки в Selection и ячейки каждой бывшей группы заполнить формулами-ссылками на их первые ячейки  
        For Each rCell In rRange  
           If rCell.MergeCells Then  
              sAddress = rCell.MergeArea.Address: rCell.UnMerge  
              For i = 2 To Range(sAddress).Cells.Count  
                 With Range(sAddress)  
                    .Cells(i).Formula = «=» & .Cells(1).Address  
                    .Cells(i).Replace What:=»$», Replacement:=»», LookAt:=xlPart  ‘ сделать ссылки перемещаемыми  
                    .Cells(i).Font.ColorIndex = 5   ‘ сделать шрифт формул синим (это на любителя, конечно)  
                 End With  
              Next i  
           End If  
        Next rCell  
     Case vbNo    ‘ разгруппировать все ячейки в Selection и ячейки каждой бывшей группы заполнить значениями из их первых ячеек  
        For Each rCell In rRange  
           If rCell.MergeCells Then  
              sAddress = rCell.MergeArea.Address: sValue = rCell.Value: rCell.UnMerge  
              Range(sAddress).Value = rCell.Value  
           End If  
        Next  
     Case vbCancel  
        If MsgBox(«Разгруппировать стандартным способом?», vbYesNo + vbQuestion) = vbYes Then Selection.UnMerge  
  End Select  
  rRange.Select  
  Application.ScreenUpdating = True  
End Sub

С уважением, Алексей (ИМХО: Excel-2003 — THE BEST!!!)
<#0>

lev