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

Вход

Регистрация

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

 

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

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

2003
Макрос MergePlus позволяет объединить ячейки в Selection без потери данных в скрываемых ячейках.
Имеется возможность либо оставить в скрываемых при группировке ячейках имеющиеся в них значения, либо заполнить скрывающиеся при группировке ячейки ссылками на значения той ячейки, которая будет видна после гуппировки (Selection(1)), или её значениями.
[vba]
Код
Sub MergePlus()
     '---------------------------------------------------------------------------------------
     ' Procedure : MergePlus
     ' Author    : The_Prist & Alex_ST
     ' URL       : http://www.planetaexcel.ru/forum.php?thread_id=13533
     ' Theme     : Объединение ячеек без потери данных
     ' Date      : 17.02.2010
     ' Purpose   : Объединить ячейки в Selection без потери данных
     '---------------------------------------------------------------------------------------
     If TypeName(Selection) <> "Range" Then Exit Sub
     If Selection.Cells.Count <= 1 Then Exit Sub
     Dim wsTempSh As Worksheet, wsActSh As Worksheet
     Dim rRange As Range, rMrgRange As Range
     Dim i%
     Application.ScreenUpdating = False: Application.DisplayAlerts = False
     Select Case MsgBox("""ДА"" - заполнить ячейки формулами-ссылками на первую ячейку" & vbCrLf & _
                        """НЕТ"" - оставить имеющиеся в ячейках значения" & vbCrLf & _
                        """ОТМЕНА"" не объединять ячейки" _
                        , vbYesNoCancel + vbQuestion + vbDefaultButton1, "Заполнить ячейки перед объединением?")
        Case vbCancel: Exit Sub
        Case vbYes   ' перед объединением заполнить Selection формулами-ссылками на первую ячейку
           For i = 2 To Selection.Cells.Count
              Selection(i).Formula = "=" & Selection(1).Address
              Selection(i).Replace What:="$", Replacement:="", LookAt:=xlPart  ' сделать ссылки перемещаемыми
           Next
     End Select
     Set wsActSh = ActiveSheet: Set wsTempSh = Sheets.Add
     wsActSh.Activate
     Set rRange = Selection: rRange.Copy wsTempSh.Range(rRange.Address)   ' копировать rRange = Selection на новую страницу
     Set rMrgRange = wsTempSh.Range(rRange.Address)   ' на новой странице объединить ячейки в rRange
     rMrgRange.Merge: rMrgRange.Copy: rRange.PasteSpecial xlPasteFormats: wsTempSh.Delete
     Set wsActSh = Nothing: Set wsTempSh = Nothing: Set rMrgRange = Nothing: Set rRange = Nothing
     Application.ScreenUpdating = True: Application.DisplayAlerts = True
End Sub
[/vba]



С уважением,
Алексей
MS Excel 2003 - the best!!!
 
Ответить
СообщениеМакрос MergePlus позволяет объединить ячейки в Selection без потери данных в скрываемых ячейках.
Имеется возможность либо оставить в скрываемых при группировке ячейках имеющиеся в них значения, либо заполнить скрывающиеся при группировке ячейки ссылками на значения той ячейки, которая будет видна после гуппировки (Selection(1)), или её значениями.
[vba]
Код
Sub MergePlus()
     '---------------------------------------------------------------------------------------
     ' Procedure : MergePlus
     ' Author    : The_Prist & Alex_ST
     ' URL       : http://www.planetaexcel.ru/forum.php?thread_id=13533
     ' Theme     : Объединение ячеек без потери данных
     ' Date      : 17.02.2010
     ' Purpose   : Объединить ячейки в Selection без потери данных
     '---------------------------------------------------------------------------------------
     If TypeName(Selection) <> "Range" Then Exit Sub
     If Selection.Cells.Count <= 1 Then Exit Sub
     Dim wsTempSh As Worksheet, wsActSh As Worksheet
     Dim rRange As Range, rMrgRange As Range
     Dim i%
     Application.ScreenUpdating = False: Application.DisplayAlerts = False
     Select Case MsgBox("""ДА"" - заполнить ячейки формулами-ссылками на первую ячейку" & vbCrLf & _
                        """НЕТ"" - оставить имеющиеся в ячейках значения" & vbCrLf & _
                        """ОТМЕНА"" не объединять ячейки" _
                        , vbYesNoCancel + vbQuestion + vbDefaultButton1, "Заполнить ячейки перед объединением?")
        Case vbCancel: Exit Sub
        Case vbYes   ' перед объединением заполнить Selection формулами-ссылками на первую ячейку
           For i = 2 To Selection.Cells.Count
              Selection(i).Formula = "=" & Selection(1).Address
              Selection(i).Replace What:="$", Replacement:="", LookAt:=xlPart  ' сделать ссылки перемещаемыми
           Next
     End Select
     Set wsActSh = ActiveSheet: Set wsTempSh = Sheets.Add
     wsActSh.Activate
     Set rRange = Selection: rRange.Copy wsTempSh.Range(rRange.Address)   ' копировать rRange = Selection на новую страницу
     Set rMrgRange = wsTempSh.Range(rRange.Address)   ' на новой странице объединить ячейки в rRange
     rMrgRange.Merge: rMrgRange.Copy: rRange.PasteSpecial xlPasteFormats: wsTempSh.Delete
     Set wsActSh = Nothing: Set wsTempSh = Nothing: Set rMrgRange = Nothing: Set rRange = Nothing
     Application.ScreenUpdating = True: Application.DisplayAlerts = True
End Sub
[/vba]

Автор - Alex_ST
Дата добавления - 30.08.2010 в 12:40
Мир MS Excel » Вопросы и решения » Готовые решения » Макрос "MergePlus" (Объединить ячейки в Selection без потери данных)
  • Страница 1 из 1
  • 1
Поиск:

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