Доброго времени форумчане! Есть макрос объединения ячеек без потери содержимого, в моём примере в ячейах A1:A16, то есть если их разъединить данные сохраняются. Мне нужно применить данный макрос к другим ячейкам, но проблема в том, что в них уже есть данные... В примере более понятно
Доброго времени форумчане! Есть макрос объединения ячеек без потери содержимого, в моём примере в ячейах A1:A16, то есть если их разъединить данные сохраняются. Мне нужно применить данный макрос к другим ячейкам, но проблема в том, что в них уже есть данные... В примере более понятноadamm1603
adamm1603, привет попробуйте вот так (предполагается, что А1:А8 - уже объединенные ячейки, с них будем копировать формат) [vba]
Код
Sub ttt() Dim r As Range With Selection .UnMerge For Each r In .SpecialCells(2).Areas With r.Resize(8) .Value = r.Value Range("A1:A8").Copy .PasteSpecial Paste:=xlPasteFormats End With Next End With Application.CutCopyMode = False End Sub
[/vba] Просто интересно - а для чего нужны такие объединенные ячейки?
adamm1603, привет попробуйте вот так (предполагается, что А1:А8 - уже объединенные ячейки, с них будем копировать формат) [vba]
Код
Sub ttt() Dim r As Range With Selection .UnMerge For Each r In .SpecialCells(2).Areas With r.Resize(8) .Value = r.Value Range("A1:A8").Copy .PasteSpecial Paste:=xlPasteFormats End With Next End With Application.CutCopyMode = False End Sub
[/vba] Просто интересно - а для чего нужны такие объединенные ячейки?nilem
Sub Rebrand() Application.ScreenUpdating = False: Application.DisplayAlerts = False Dim rng As Range Set rng = Selection rng.UnMerge For Each cell In rng.Cells cell.Value = ActiveCell.Value Next cell obedinenie_ycheek Application.ScreenUpdating = True: Application.DisplayAlerts = True End Sub
Sub Rebrand() Application.ScreenUpdating = False: Application.DisplayAlerts = False Dim rng As Range Set rng = Selection rng.UnMerge For Each cell In rng.Cells cell.Value = ActiveCell.Value Next cell obedinenie_ycheek Application.ScreenUpdating = True: Application.DisplayAlerts = True End Sub
Просто интересно - а для чего нужны такие объединенные ячейки?
Суть в том, что руководство предоставило нам таблицу в которой ячейки объеденные и этого не избежать, но проблема в том, что фильтр в данном случае не работает как надо, вот мне и пришлось прибегнуть к макросу объединения ячеек без потери данных, что бы фильтр работал корректно. А Ваш макрос позволит мне так скажем преобразовать ячейки без потери данных!
Просто интересно - а для чего нужны такие объединенные ячейки?
Суть в том, что руководство предоставило нам таблицу в которой ячейки объеденные и этого не избежать, но проблема в том, что фильтр в данном случае не работает как надо, вот мне и пришлось прибегнуть к макросу объединения ячеек без потери данных, что бы фильтр работал корректно. А Ваш макрос позволит мне так скажем преобразовать ячейки без потери данных!adamm1603
nilem всё работает, а есть возможность подкорректировать макрос, что бы он копировал не только значения но и формулы, то есть в моём примере первая (верхняя) ячейка содержит число, текст, а остальные привязаны через[vba]
Код
=###
[/vba] K-SerJC у вас то же всё работает, хотелось что бы макрос работал с областью, а не конкретно с ячейкой, но всё равно спасибо!
nilem всё работает, а есть возможность подкорректировать макрос, что бы он копировал не только значения но и формулы, то есть в моём примере первая (верхняя) ячейка содержит число, текст, а остальные привязаны через[vba]
Код
=###
[/vba] K-SerJC у вас то же всё работает, хотелось что бы макрос работал с областью, а не конкретно с ячейкой, но всё равно спасибо!adamm1603
Sub ttt() Dim r As Range With Selection .UnMerge For Each r In .SpecialCells(2).Areas With r.Resize(8) .Offset(1).Resize(7).Formula = "=" & r.Address Range("A1:A8").Copy .PasteSpecial Paste:=xlPasteFormats End With Next End With Application.CutCopyMode = False End Sub
[/vba]
с формулой попробуйте вот так: [vba]
Код
Sub ttt() Dim r As Range With Selection .UnMerge For Each r In .SpecialCells(2).Areas With r.Resize(8) .Offset(1).Resize(7).Formula = "=" & r.Address Range("A1:A8").Copy .PasteSpecial Paste:=xlPasteFormats End With Next End With Application.CutCopyMode = False End Sub
Вход
Регистрация
Напомнить пароль
Автосумма
Часто используемые
ВПР
ЕСЛИ
СУММЕСЛИ
Финансовые
Логические
Текстовые
Даты и времени 
Ссылки и массивы 
Математические
Другие функции
Проверка свойств и значений
Баз данных
Математические
Обработки массивов
Обработки строк
Преобразования типов данных 
Загрузки данных
Работы с файлами
Обработки системных параметров
Обработки цвета
Работы с датами и временем
Преобразования в системы счисления
Финансовые
