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

Вход

Регистрация

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

 

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

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

2003
Макрос ReMerge является упрощенной версией макроса MergePlus
Позволяет "одним движением" перегруппировать по методу MergePlus сгруппированную ячейку или сгруппировать ячейки выделенного диапазона с заполнением скрываемых ячеек формулами-ссылками на первую ячейку.
[vba]
Code
Sub ReMerge()   ' перегруппировать сгруппированную ячейку или сгруппировать ячейки выделенного диапазона с заполнением скрытых ячеек формулами-ссылками на первую ячейку
     If TypeName(Selection) <> "Range" Then Exit Sub
     If Selection.Cells.Count <= 1 Then Exit Sub
     Dim i%, iCell As Range, ActRng As Range
     Dim ActSh As Worksheet, TempSh As Worksheet
     Dim lLastRow&: lLastRow = Cells.SpecialCells(xlLastCell).Row
     Dim lLastCol&: lLastCol = Selection.Column + Selection.Columns.Count - 1
     If lLastRow > Selection.Row + Selection.Rows.Count - 1 Then lLastRow = Selection.Row + Selection.Rows.Count - 1
     Set ActRng = Intersect(Selection, Range(Cells(Selection.Row, Selection.Column), Cells(lLastRow, lLastCol)))
     Application.ScreenUpdating = False: Application.DisplayAlerts = False

     Set ActSh = ActiveSheet: Set TempSh = Sheets.Add   ' запомнить текущую и создать новую страницу
     ActRng.Copy TempSh.Range(ActRng.Address)
     ActSh.Activate
     Selection.UnMerge
     For i = 2 To ActRng.Cells.Count   ' заполнить Selection формулами-ссылками на первую ячейку
        ActRng(i).Formula = "=" & ActRng(1).Address
        ActRng(i).Replace What:="$", Replacement:="", LookAt:=xlPart  ' сделать ссылки перемещаемыми
     Next
     TempSh.Range(ActRng.Address).Merge
     TempSh.Range(ActRng.Address).Copy: ActRng.PasteSpecial xlPasteFormats: TempSh.Delete
     Set ActSh = Nothing: Set TempSh = Nothing: Set ActRng = Nothing
     Application.ScreenUpdating = True: Application.DisplayAlerts = True
End Sub
[/vba]



С уважением,
Алексей
MS Excel 2003 - the best!!!
 
Ответить
СообщениеМакрос ReMerge является упрощенной версией макроса MergePlus
Позволяет "одним движением" перегруппировать по методу MergePlus сгруппированную ячейку или сгруппировать ячейки выделенного диапазона с заполнением скрываемых ячеек формулами-ссылками на первую ячейку.
[vba]
Code
Sub ReMerge()   ' перегруппировать сгруппированную ячейку или сгруппировать ячейки выделенного диапазона с заполнением скрытых ячеек формулами-ссылками на первую ячейку
     If TypeName(Selection) <> "Range" Then Exit Sub
     If Selection.Cells.Count <= 1 Then Exit Sub
     Dim i%, iCell As Range, ActRng As Range
     Dim ActSh As Worksheet, TempSh As Worksheet
     Dim lLastRow&: lLastRow = Cells.SpecialCells(xlLastCell).Row
     Dim lLastCol&: lLastCol = Selection.Column + Selection.Columns.Count - 1
     If lLastRow > Selection.Row + Selection.Rows.Count - 1 Then lLastRow = Selection.Row + Selection.Rows.Count - 1
     Set ActRng = Intersect(Selection, Range(Cells(Selection.Row, Selection.Column), Cells(lLastRow, lLastCol)))
     Application.ScreenUpdating = False: Application.DisplayAlerts = False

     Set ActSh = ActiveSheet: Set TempSh = Sheets.Add   ' запомнить текущую и создать новую страницу
     ActRng.Copy TempSh.Range(ActRng.Address)
     ActSh.Activate
     Selection.UnMerge
     For i = 2 To ActRng.Cells.Count   ' заполнить Selection формулами-ссылками на первую ячейку
        ActRng(i).Formula = "=" & ActRng(1).Address
        ActRng(i).Replace What:="$", Replacement:="", LookAt:=xlPart  ' сделать ссылки перемещаемыми
     Next
     TempSh.Range(ActRng.Address).Merge
     TempSh.Range(ActRng.Address).Copy: ActRng.PasteSpecial xlPasteFormats: TempSh.Delete
     Set ActSh = Nothing: Set TempSh = Nothing: Set ActRng = Nothing
     Application.ScreenUpdating = True: Application.DisplayAlerts = True
End Sub
[/vba]

Автор - Alex_ST
Дата добавления - 30.08.2010 в 12:55
Гость Дата: Понедельник, 31.01.2011, 12:13 | Сообщение № 2
Группа: Гости
а можно этим методом выделить один столбец, а потом остальные по образцу, кисточкой??

у меня 7 000 строк, объединенных неправильным образом(
фильтры не работают.

 
Ответить
Сообщениеа можно этим методом выделить один столбец, а потом остальные по образцу, кисточкой??

у меня 7 000 строк, объединенных неправильным образом(
фильтры не работают.


Автор - Гость
Дата добавления - 31.01.2011 в 12:13
Alex_ST Дата: Понедельник, 31.01.2011, 22:18 | Сообщение № 3
Группа: Друзья
Ранг: Участник клуба
Сообщений: 3121
Репутация: 592 ±
Замечаний: 0% ±

2003
Нет. Форматом по образцу не получится. Ведь ячейки не просто объединены без потери данных, а в невидимых ячейках ещё и прописаны формулы-ссылки на первую ячейку объединённой группы.
Но к вашему счастью, я уже давно сделал, но не выложил сюда макрос, который переобъединит все объединённые ячейки с одновременным заполнением скрываемых формулами.
Попробуйте просто выделить на листе область с несколькими объединенными ячейками и выполнить этот макрос:[vba]
Код
Sub ReMergeEach()   ' перегруппировать каждую сгруппированную ячейку в выделенном диапазоне с заполнением скрытых ячеек формулами-ссылками на первую ячейку
       If TypeName(Selection) <> "Range" Then Exit Sub
       If Selection.Cells.Count <= 1 Then Exit Sub
       Dim i%, iCell As Range, ActRng As Range
       Dim ActSh As Worksheet, TempSh As Worksheet
       Dim lLastRow&: lLastRow = Cells.SpecialCells(xlLastCell).Row
       Dim lLastCol&: lLastCol = Selection.Column + Selection.Columns.Count - 1
       If lLastRow > Selection.Row + Selection.Rows.Count - 1 Then lLastRow = Selection.Row + Selection.Rows.Count - 1
       Set ActRng = Intersect(Selection, Range(Cells(Selection.Row, Selection.Column), Cells(lLastRow, lLastCol)))
       Application.ScreenUpdating = False: Application.DisplayAlerts = False: Application.EnableEvents = False
       Set ActSh = ActiveSheet: Set TempSh = Sheets.Add   ' запомнить текущую и создать новую страницу
       ActRng.Copy TempSh.Range(ActRng.Address)   ' копировать ActRng на новую страницу
       ActSh.Activate
       For Each iCell In ActRng
           If iCell.MergeCells Then  ' разгруппировать и заполнить ранее скрытые ячейки формулами-ссылками на первые ячейки
               iCell.Select
               Selection.UnMerge
               For i = 2 To Selection.Cells.Count   ' заполнить Selection формулами-ссылками на первую ячейку
                   Selection(i).Formula = "=" & Selection(1).Address
                   Selection(i).Replace What:="$", Replacement:="", LookAt:=xlPart  ' сделать ссылки перемещаемыми
               Next
           End If
       Next
       TempSh.Range(ActRng.Address).Copy: ActRng.PasteSpecial xlPasteFormats: TempSh.Delete
       Set ActSh = Nothing: Set TempSh = Nothing: Set ActRng = Nothing
       Application.ScreenUpdating = True: Application.DisplayAlerts = True: Application.EnableEvents = True
End Sub
[/vba]

всё, вроде бы работает как надо.



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


Сообщение отредактировал Alex_ST - Понедельник, 31.01.2011, 22:19
 
Ответить
СообщениеНет. Форматом по образцу не получится. Ведь ячейки не просто объединены без потери данных, а в невидимых ячейках ещё и прописаны формулы-ссылки на первую ячейку объединённой группы.
Но к вашему счастью, я уже давно сделал, но не выложил сюда макрос, который переобъединит все объединённые ячейки с одновременным заполнением скрываемых формулами.
Попробуйте просто выделить на листе область с несколькими объединенными ячейками и выполнить этот макрос:[vba]
Код
Sub ReMergeEach()   ' перегруппировать каждую сгруппированную ячейку в выделенном диапазоне с заполнением скрытых ячеек формулами-ссылками на первую ячейку
       If TypeName(Selection) <> "Range" Then Exit Sub
       If Selection.Cells.Count <= 1 Then Exit Sub
       Dim i%, iCell As Range, ActRng As Range
       Dim ActSh As Worksheet, TempSh As Worksheet
       Dim lLastRow&: lLastRow = Cells.SpecialCells(xlLastCell).Row
       Dim lLastCol&: lLastCol = Selection.Column + Selection.Columns.Count - 1
       If lLastRow > Selection.Row + Selection.Rows.Count - 1 Then lLastRow = Selection.Row + Selection.Rows.Count - 1
       Set ActRng = Intersect(Selection, Range(Cells(Selection.Row, Selection.Column), Cells(lLastRow, lLastCol)))
       Application.ScreenUpdating = False: Application.DisplayAlerts = False: Application.EnableEvents = False
       Set ActSh = ActiveSheet: Set TempSh = Sheets.Add   ' запомнить текущую и создать новую страницу
       ActRng.Copy TempSh.Range(ActRng.Address)   ' копировать ActRng на новую страницу
       ActSh.Activate
       For Each iCell In ActRng
           If iCell.MergeCells Then  ' разгруппировать и заполнить ранее скрытые ячейки формулами-ссылками на первые ячейки
               iCell.Select
               Selection.UnMerge
               For i = 2 To Selection.Cells.Count   ' заполнить Selection формулами-ссылками на первую ячейку
                   Selection(i).Formula = "=" & Selection(1).Address
                   Selection(i).Replace What:="$", Replacement:="", LookAt:=xlPart  ' сделать ссылки перемещаемыми
               Next
           End If
       Next
       TempSh.Range(ActRng.Address).Copy: ActRng.PasteSpecial xlPasteFormats: TempSh.Delete
       Set ActSh = Nothing: Set TempSh = Nothing: Set ActRng = Nothing
       Application.ScreenUpdating = True: Application.DisplayAlerts = True: Application.EnableEvents = True
End Sub
[/vba]

всё, вроде бы работает как надо.

Автор - Alex_ST
Дата добавления - 31.01.2011 в 22:18
Гисер Дата: Пятница, 27.09.2013, 09:09 | Сообщение № 4
Группа: Пользователи
Ранг: Новичок
Сообщений: 14
Репутация: 0 ±
Замечаний: 0% ±

Excel 2010
Чего то у меня не работает( Вставил в VBA, выполняю макрос обедняете как обычно только не спрашивает разрешения
 
Ответить
СообщениеЧего то у меня не работает( Вставил в VBA, выполняю макрос обедняете как обычно только не спрашивает разрешения

Автор - Гисер
Дата добавления - 27.09.2013 в 09:09
Alex_ST Дата: Пятница, 27.09.2013, 13:01 | Сообщение № 5
Группа: Друзья
Ранг: Участник клуба
Сообщений: 3121
Репутация: 592 ±
Замечаний: 0% ±

2003
Чего то у меня не работает
А объединённые макросом ячейки Вы разъединить не пробовали?
А если пробовали, то неужели не заметили разницы с результатом разъединения объединённых ранее стандартным способом ячеек?



С уважением,
Алексей
MS Excel 2003 - the best!!!
 
Ответить
Сообщение
Чего то у меня не работает
А объединённые макросом ячейки Вы разъединить не пробовали?
А если пробовали, то неужели не заметили разницы с результатом разъединения объединённых ранее стандартным способом ячеек?

Автор - Alex_ST
Дата добавления - 27.09.2013 в 13:01
Юрий_Ф Дата: Четверг, 23.07.2020, 18:45 | Сообщение № 6
Группа: Проверенные
Ранг: Обитатель
Сообщений: 259
Репутация: -9 ±
Замечаний: 0% ±

Excel 2010
Что-то я не понял!
Создал макрос, скопировал в него вашу программку. А он не объединяет содержимое ячеек, а объединяет, сохраняя содержимое только первой а второе содержимое пропадает. А главное, потом отменить это невозможно!


То, что мы делаем, завораживает!
Кстати! Я не могу всем нравиться! И это взаимно!
 
Ответить
СообщениеЧто-то я не понял!
Создал макрос, скопировал в него вашу программку. А он не объединяет содержимое ячеек, а объединяет, сохраняя содержимое только первой а второе содержимое пропадает. А главное, потом отменить это невозможно!

Автор - Юрий_Ф
Дата добавления - 23.07.2020 в 18:45
Alex_ST Дата: Четверг, 23.07.2020, 21:31 | Сообщение № 7
Группа: Друзья
Ранг: Участник клуба
Сообщений: 3121
Репутация: 592 ±
Замечаний: 0% ±

2003
Юрий_Ф, а с чего Вы взяли, что описанная здесь процедура должна объединять (т.е. "склеивать") СОДЕРЖИМОЕ ячеек?
Она именно создаёт объединённую ячейку из выделенного диапазона. Процедура - замена стандартного объединения ячеек Excel, которое просто стирает содержимое всех объединяемых ячеек и даёт объединённой ячейке значение из левой верхней (первой) ячейки выделенного диапазона.
А данная процедура позволяет не стирать значения из скрытых при объединении ячеек.
Прочтите первый пост данного топика. Там всё написано и есть ссылка на более продвинутый макрос MergePlus, назначение и возможности которого там же описаны в первом посте.
А для "склеивания" содержимого выделенных ячеек я где-то здесь выкладывал другой макрос... Но это было очень давно и трудно найти...
Т.к. найти не смог, то пойду на оффтоп (да простят меня модераторы!) и выложу несколько вариантов макроса здесь под спойлером



С уважением,
Алексей
MS Excel 2003 - the best!!!
 
Ответить
СообщениеЮрий_Ф, а с чего Вы взяли, что описанная здесь процедура должна объединять (т.е. "склеивать") СОДЕРЖИМОЕ ячеек?
Она именно создаёт объединённую ячейку из выделенного диапазона. Процедура - замена стандартного объединения ячеек Excel, которое просто стирает содержимое всех объединяемых ячеек и даёт объединённой ячейке значение из левой верхней (первой) ячейки выделенного диапазона.
А данная процедура позволяет не стирать значения из скрытых при объединении ячеек.
Прочтите первый пост данного топика. Там всё написано и есть ссылка на более продвинутый макрос MergePlus, назначение и возможности которого там же описаны в первом посте.
А для "склеивания" содержимого выделенных ячеек я где-то здесь выкладывал другой макрос... Но это было очень давно и трудно найти...
Т.к. найти не смог, то пойду на оффтоп (да простят меня модераторы!) и выложу несколько вариантов макроса здесь под спойлером

Автор - Alex_ST
Дата добавления - 23.07.2020 в 21:31
Мир MS Excel » Вопросы и решения » Готовые решения » Макрос "ReMerge" (Перегруппировать ячейки по методу MergePlus)
  • Страница 1 из 1
  • 1
Поиск:

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