Помогите, пожалуйста. Требуется снять объединение ячеек с заполнением всех разъединенных ячеек значением, которое было в объединенной ячейке. Таблицы большие, ручная работа утомляет. Как ускорить процесс? Спасибо.
Тыкаем в объединенную ячейку и запускаем макрос: Sub Макрос1() a = Selection.Value Selection.UnMerge For Each rr In Selection rr.Value = a Next End Sub
А ведь тема-то интересная, часто нужная и так и не доведенная до ума... Вот есть, например, таблица - штатное расписание организации (ну, или табличное описание чего угодно, имеющего иерархическую структуру) составленное с использованием объединенных ячеек. Естественно, что из-за наличия объединенных ячеек такую таблицу нормально фильтровать будет невозможно, а уж о том, чтобы перенести информацию в базу данных даже и подумать страшно... Макрос типа:
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
Что-то у меня не работает... Ругается "Недопустимое число аргументов или присвоение значения свойства.
Т.к. после 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!!!)
The_Prist , если выделить целиком несколько столбцов, то разгруппировывает очень долго... Надо бы, наверное, как-то ограничить обрабатываемый диапазон "до последней используемой строки". А как это сделать?
СПАСИБО, The_Prist !!! Вы пишете макросы быстрее чем я их тестирую... Всё теперь отлично и быстро работает. А что надо изменить чтобы в разгруппированные ячейки вставлялось не значение первой ("главной") ячейки, а формула =главной_ячейке? Тогда, изменив "ключевую" ячейку, мы сразу же изменим и те, с которыми она была сгруппирована. Ну, а уж после всех исправлений можно будет и специальной вставкой формулы на значения заменить.
С уважением, Алексей(ИМХО: Excel-2003 - THE BEST!!!)
вот тут "в лёт" не получилось... 1. Разгруппировываются все ячейки в столбце даже если выбран ограниченный диапазон, а не столбец. 2. Формула по строкам (сверху вниз) размножается правильно, а по столбцам (слева-направо) - нет. Берет значения из ячейки выше, а не слева... Пункт 2 попробую, конечно, сам исправить, но это мне ещё придётся побиться...
С уважением, Алексей(ИМХО: Excel-2003 - THE BEST!!!)
Да! Отлично! Всё работает! СПАСИБО! Ща запихну эти два кода к себе в Personal.xls и сделаю для них кнопочки на панели управления (не забыть бы потом Excel11.xlb в XLSTART переложить чтобы настройки не пропали)
С уважением, Алексей(ИМХО: Excel-2003 - THE BEST!!!)
на всякий случай если кому-нибудь надо: 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!!!)
Пардон, не углядел небольшую неточность... Диапазон выделения не ограничивается 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!!!)
Разбирался с кучей макросов в своём 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!!!)
Пишу дисер, столкнулся с такой проблемой - по первой же ссылке нашел ваш форум. Спасибо ребята за Ваши труды! Очень помогли! Добро всегда возвращается! Спасибо!