Домашняя страница Undo Do New Save Карта сайта Обратная связь Поиск по форуму
МИР MS EXCEL - Гость.xls

Вход

Регистрация

Напомнить пароль

 

= Мир MS Excel/Макрос "UnMerge_and_Fill" - Мир MS Excel

Старая форма входа
  • Страница 1 из 1
  • 1
Модератор форума: _Boroda_, китин  
Мир MS Excel » Вопросы и решения » Готовые решения » Макрос "UnMerge_and_Fill" (Разгруппировать ячейки выделенного диапазона с заполнением)
Макрос "UnMerge_and_Fill"
Alex_ST Дата: Понедельник, 30.08.2010, 12:18 | Сообщение № 1
Группа: Друзья
Ранг: Участник клуба
Сообщений: 3197
Репутация: 606 ±
Замечаний: 0% ±

2003
Макрос UnMerge_and_Fill позволяет заполнить открывшиеся после разгруппировки ячейки каждого сгруппированного диапазона в Selection либо ссылками на значения той ячейки, которая была видна до разргуппировки, либо её значениями.

[vba]
Код
Sub UnMerge_and_Fill()
     '---------------------------------------------------------------------------------------
     ' Procedure    : UnMerge_and_Fill
     ' Author       : The_Prist & Alex_ST
     ' Topic_HEADER : Снятие объединения ячеек с заполнением
     ' Topic_URL    : http://www.planetaexcel.ru/forum.php?thread_id=3760
     ' Purpose      : Снимает объединение со всех ячеек выделенного диапазона
     '                и заполняет все разгруппированные ячейки КАЖДОЙ бывшей группы
     '                либо ссылками на значения верхней левой, либо её значениями
     '---------------------------------------------------------------------------------------
     If TypeName(Selection) <> "Range" Then Exit Sub
     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
[/vba]



С уважением,
Алексей
MS Excel 2003 - the best!!!
 
Ответить
СообщениеМакрос UnMerge_and_Fill позволяет заполнить открывшиеся после разгруппировки ячейки каждого сгруппированного диапазона в Selection либо ссылками на значения той ячейки, которая была видна до разргуппировки, либо её значениями.

[vba]
Код
Sub UnMerge_and_Fill()
     '---------------------------------------------------------------------------------------
     ' Procedure    : UnMerge_and_Fill
     ' Author       : The_Prist & Alex_ST
     ' Topic_HEADER : Снятие объединения ячеек с заполнением
     ' Topic_URL    : http://www.planetaexcel.ru/forum.php?thread_id=3760
     ' Purpose      : Снимает объединение со всех ячеек выделенного диапазона
     '                и заполняет все разгруппированные ячейки КАЖДОЙ бывшей группы
     '                либо ссылками на значения верхней левой, либо её значениями
     '---------------------------------------------------------------------------------------
     If TypeName(Selection) <> "Range" Then Exit Sub
     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
[/vba]

Автор - Alex_ST
Дата добавления - 30.08.2010 в 12:18
Alex_ST Дата: Понедельник, 11.02.2013, 12:29 | Сообщение № 2
Группа: Друзья
Ранг: Участник клуба
Сообщений: 3197
Репутация: 606 ±
Замечаний: 0% ±

2003
А если без вопросов заполнять разгруппированные ячейки значениями из первой, то ещё проще:[vba]
Код
Sub UnMerge_and_Fill_by_Value()   ' разгруппировать все ячейки в Selection и ячейки каждой бывшей группы заполнить значениями из их первых ячеек
    If TypeName(Selection) <> "Range" Then Exit Sub
    If Selection.Cells.Count <= 1 Then Exit Sub
    Dim rCell As Range, sValue$, sAddress$, i&
    Application.ScreenUpdating = False
    For Each rCell In Intersect(Selection, ActiveSheet.UsedRange)
       If rCell.MergeCells Then
          sAddress = rCell.MergeArea.Address: rCell.UnMerge
          Range(sAddress).Value = rCell.Value
       End If
    Next
    Application.ScreenUpdating = True
End Sub
[/vba]



С уважением,
Алексей
MS Excel 2003 - the best!!!
 
Ответить
СообщениеА если без вопросов заполнять разгруппированные ячейки значениями из первой, то ещё проще:[vba]
Код
Sub UnMerge_and_Fill_by_Value()   ' разгруппировать все ячейки в Selection и ячейки каждой бывшей группы заполнить значениями из их первых ячеек
    If TypeName(Selection) <> "Range" Then Exit Sub
    If Selection.Cells.Count <= 1 Then Exit Sub
    Dim rCell As Range, sValue$, sAddress$, i&
    Application.ScreenUpdating = False
    For Each rCell In Intersect(Selection, ActiveSheet.UsedRange)
       If rCell.MergeCells Then
          sAddress = rCell.MergeArea.Address: rCell.UnMerge
          Range(sAddress).Value = rCell.Value
       End If
    Next
    Application.ScreenUpdating = True
End Sub
[/vba]

Автор - Alex_ST
Дата добавления - 11.02.2013 в 12:29
nerv Дата: Среда, 13.02.2013, 01:31 | Сообщение № 3
Группа: Редакторы
Ранг: Обитатель
Сообщений: 431
Репутация: 193 ±
Замечаний: 0% ±

smile

[vba]
Код
Sub UnMerge_And_Fill_By_Value() ' разгруппировать все ячейки в Selection и ячейки каждой бывшей группы заполнить значениями из их первых ячеек
     Dim Address As String
     Dim Cell As Range

     If TypeName(Selection) <> "Range" Then
         Exit Sub
     End If
      
     If Selection.Cells.Count = 1 Then
         Exit Sub
     End If
      
     Application.ScreenUpdating =  False
          
     For Each Cell In Intersect(Selection, ActiveSheet.UsedRange).Cells
         If Cell.MergeCells Then
             Address = Cell.MergeArea.Address
             Cell.UnMerge
             Range(Address).Value = Cell.Value
         End If
     Next
End Sub
[/vba]


Чебурашка стал символом олимпийских игр. А чего достиг ты?
Тишина - самый громкий звук


YM 41001156540584 / WM WMR R21924176233

https://github.com/nervgh/vba


Сообщение отредактировал nerv - Среда, 13.02.2013, 01:34
 
Ответить
Сообщениеsmile

[vba]
Код
Sub UnMerge_And_Fill_By_Value() ' разгруппировать все ячейки в Selection и ячейки каждой бывшей группы заполнить значениями из их первых ячеек
     Dim Address As String
     Dim Cell As Range

     If TypeName(Selection) <> "Range" Then
         Exit Sub
     End If
      
     If Selection.Cells.Count = 1 Then
         Exit Sub
     End If
      
     Application.ScreenUpdating =  False
          
     For Each Cell In Intersect(Selection, ActiveSheet.UsedRange).Cells
         If Cell.MergeCells Then
             Address = Cell.MergeArea.Address
             Cell.UnMerge
             Range(Address).Value = Cell.Value
         End If
     Next
End Sub
[/vba]

Автор - nerv
Дата добавления - 13.02.2013 в 01:31
Alex_ST Дата: Среда, 13.02.2013, 09:46 | Сообщение № 4
Группа: Друзья
Ранг: Участник клуба
Сообщений: 3197
Репутация: 606 ±
Замечаний: 0% ±

2003
nerv,
а чем это от моего варианта отличается?
Только тем, что у тебя имена переменных "не по фэншую" :), а я у себя забыл убрать лишние переменные i& и sValue$
И тем, что в Intersect(Selection, ActiveSheet.UsedRange) явно указано свойство .Cells? Ну, тут спорить не буду: "по фэншую" надо именно так и писАть, т.к. по умолчанию свойство Range - Value ... Но ведь и так как у меня нормально работает, значит VBA понимает, что речь идёт про .Cells , а не про .Value
Но для фэншуя , пожалуй, у себя допишу в макрос .Cells



С уважением,
Алексей
MS Excel 2003 - the best!!!


Сообщение отредактировал Alex_ST - Среда, 13.02.2013, 09:52
 
Ответить
Сообщениеnerv,
а чем это от моего варианта отличается?
Только тем, что у тебя имена переменных "не по фэншую" :), а я у себя забыл убрать лишние переменные i& и sValue$
И тем, что в Intersect(Selection, ActiveSheet.UsedRange) явно указано свойство .Cells? Ну, тут спорить не буду: "по фэншую" надо именно так и писАть, т.к. по умолчанию свойство Range - Value ... Но ведь и так как у меня нормально работает, значит VBA понимает, что речь идёт про .Cells , а не про .Value
Но для фэншуя , пожалуй, у себя допишу в макрос .Cells

Автор - Alex_ST
Дата добавления - 13.02.2013 в 09:46
nerv Дата: Среда, 13.02.2013, 11:18 | Сообщение № 5
Группа: Редакторы
Ранг: Обитатель
Сообщений: 431
Репутация: 193 ±
Замечаний: 0% ±

Цитата (Alex_ST)
а чем это от моего варианта отличается?

форматированием


Чебурашка стал символом олимпийских игр. А чего достиг ты?
Тишина - самый громкий звук


YM 41001156540584 / WM WMR R21924176233

https://github.com/nervgh/vba
 
Ответить
Сообщение
Цитата (Alex_ST)
а чем это от моего варианта отличается?

форматированием

Автор - nerv
Дата добавления - 13.02.2013 в 11:18
Мир MS Excel » Вопросы и решения » Готовые решения » Макрос "UnMerge_and_Fill" (Разгруппировать ячейки выделенного диапазона с заполнением)
  • Страница 1 из 1
  • 1
Поиск:

Яндекс.Метрика Яндекс цитирования
© 2010-2024 · Дизайн: MichaelCH · Хостинг от uCoz · При использовании материалов сайта, ссылка на www.excelworld.ru обязательна!