Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
Доработка макроса для переноса примечания к ячейке
 
#1
07.08.2022 19:39:39
Добрый день! Есть макрос, который копирует ячейки из отфильтрованного диапазона одной таблицы в отфильтрованный диапазон другой (фильтры настроены одинаково).  Данные переносятся вместе с форматом ячеек и самого текста. Необходимо добавить условие, чтобы ячейка переносила и примечание к ней при копировании. Тестовая табличка во вложении (в данном примере перенос с листа1 на лист 2). Помогите с решением, пожалуйста.

Код:

Sub PasteToVisible()
Dim copyrng As Range, pasterng As Range
Dim cell As Range, i As Long

'запрашиваем у пользователя по очереди диапазоны копирования и вставки
Set copyrng = Application.InputBox("Диапазон копирования", "Запрос", Type:=8)
Set pasterng = Application.InputBox("Диапазон вставки", "Запрос", Type:=8)

'проверяем, чтобы они были одинакового размера
If pasterng.Cells.Cells.Count <> copyrng.Cells.Count Then
MsgBox "Диапазоны копирования и вставки разного размера!", vbCritical
Exit Sub
End If

'переносим данные из одного диапазона в другой только в видимые ячейки
For Each cell In pasterng
If cell.EntireRow.Hidden = False Then
cell.Value = Cells(cell.Row, copyrng.Column).Value
cell.Interior.Color = Cells(cell.Row, copyrng.Column).Interior.Color
cell.Font.Color = Cells(cell.Row, copyrng.Column).Font.Color
cell.Borders(xlEdgeBottom).LineStyle = Cells(cell.Row, copyrng.Column).Borders(xlEdgeBottom).LineStyle
cell.Borders(xlEdgeBottom).Weight = Cells(cell.Row, copyrng.Column).Borders(xlEdgeBottom).Weight
cell.Borders(xlEdgeBottom).Color = Cells(cell.Row, copyrng.Column).Borders(xlEdgeBottom).Color
cell.Borders(xlEdgeRight).LineStyle = Cells(cell.Row, copyrng.Column).Borders(xlEdgeRight).LineStyle
cell.Borders(xlEdgeRight).Weight = Cells(cell.Row, copyrng.Column).Borders(xlEdgeRight).Weight
cell.Borders(xlEdgeRight).Color = Cells(cell.Row, copyrng.Column).Borders(xlEdgeRight).Color
cell.Borders(xlEdgeLeft).LineStyle = Cells(cell.Row, copyrng.Column).Borders(xlEdgeLeft).LineStyle
cell.Borders(xlEdgeLeft).Weight = Cells(cell.Row, copyrng.Column).Borders(xlEdgeLeft).Weight
cell.Borders(xlEdgeLeft).Color = Cells(cell.Row, copyrng.Column).Borders(xlEdgeLeft).Color
cell.Borders(xlEdgeTop).LineStyle = Cells(cell.Row, copyrng.Column).Borders(xlEdgeTop).LineStyle
cell.Borders(xlEdgeTop).Weight = Cells(cell.Row, copyrng.Column).Borders(xlEdgeTop).Weight
cell.Borders(xlEdgeTop).Color = Cells(cell.Row, copyrng.Column).Borders(xlEdgeTop).Color
cell.Font.Name = Cells(cell.Row, copyrng.Column).Font.Name
cell.Font.Size = Cells(cell.Row, copyrng.Column).Font.Size
cell.Font.Bold = Cells(cell.Row, copyrng.Column).Font.Bold
cell.Font.Italic = Cells(cell.Row, copyrng.Column).Font.Italic
End If
  Next cell

End Sub
 
 
 
#2
07.08.2022 22:55:10
если макрос есть - то пользуйтесь им
если он не хрена не делает - напишите какую задачу решаете, а не публикуйте тут бестолковый макрос
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!
 
 
 
#3
08.08.2022 08:17:55
Добрый день. Задача: копирование дипозона ячеек в другой диапазон (фильтры в двух таблицах идентичны) с сохранением формата текста (цвет, шрифт), формата ячейки (границы, заливка) и примечаний к ячейке вместе с текстом.
Указанный макрос работает на все, за исключением переноса примечания к ячейке. С этим собственно и нужна помошь.
 
 
 
#4
08.08.2022 09:23:14
а такой макрос не подойдет?
Код
Sub PasteToVisible()
  Dim copyrng As Range, pasterng As Range
  'запрашиваем у пользователя по очереди диапазоны копирования и вставки
  Set copyrng = Application.InputBox("Диапазон копирования", "Запрос", Type:=8)
  Set pasterng = Application.InputBox("Диапазон вставки", "Запрос", Type:=8)
  copyrng.copy pasterng
End Sub
и чем это лучше чем просто без всяких макросов отметить один диапазон Ctrl+C, переместить курсор в нужную ячейку Ctrl+V
Изменено: Ігор Гончаренко - 08.08.2022 09:26:18
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!
 
 
 
#5
08.08.2022 09:41:46
Игорь, к сожалению предложенный макрос не работает. Выдает ошибку "данная команда не применима для несвязанных диапазонов".
Стандартная команда Ctrl+C,Ctrl+V в этом случае не работает правильно, т.к. копируем и вставляем мы в таблицах, в которых установлены фильтры.
 
 
 
#6
08.08.2022 09:51:08
а так?
Код
Sub PasteToVisible()
  Dim copyrng As Range, pasterng As Range, cell As Range
  'запрашиваем у пользователя по очереди диапазоны копирования и вставки
  Set copyrng = Application.InputBox("Диапазон копирования", "Запрос", Type:=8)
  Set pasterng = Application.InputBox("Диапазон вставки", "Запрос", Type:=8)
  For Each cell in pasterng
    Cells(cell.Row, copyrng.Column).copy cell
    cell = Cells(cell.Row, copyrng.Column)
  Next
End Sub
Изменено: Ігор Гончаренко - 08.08.2022 09:54:18
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!
 
 
 
#7
08.08.2022 10:55:02
Игорь, спасибо большое, работает. Очень выручили!
 
 
 
#8
09.08.2022 10:40:57
Игорь, возможно вы сможете помочь еще с одной задачей по этому макросу. Он работает если мы копируем данные по одному столбцу, но если нужно скопировать сразу несколько, то в первый столбец он переносит все верно, а вот во второй и последующий копирует данные  из 1 столбца, а не из соответствующих столбцов исходной таблицы.
 
 
 
#9
09.08.2022 10:52:16
копируйте по одному столбцу все получится) ни для чего более макрос не предназначен

нужен другой макрос? нужно описание задачи, которую он будет решать
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!
 
 
 
#10
09.08.2022 11:36:34
Игорь,
к сожалению, если в таблице много колонок, то копирование каждой достаточно длительный процесс. А так да, по одной колонке работает)

С корректировкой задача звучит так: копирование диапазона ячеек из нескольких столбцов таблицы и их перенос  в другую таблицу, данные должны переносится  в аналогичные столбцы новой таблицы (столбец А - в столбец А, В в В и т.д.)  с сохранением формата (в двух таблицах настроены одинаковые фильтры)
 
 
 
#11
09.08.2022 11:38:43
Если, как в примере, нужно копировать видимые (отфильтрованные ячейки) одного листа на другой с такой же структурой, то можно так:
Код
Sub PasteToVisible1()
  
  Dim rArea As Range, rFrom As Range, rTo As Range
  
  On Error GoTo exit_
  
  'Запросить диапазон копирования (по умолчанию - выделенные ячейки)
  Set rFrom = Application.InputBox("Диапазон копирования", "Запрос", Default:=Selection.Address(0, 0), Type:=8)
  
  'Запросить лист вставки (любую ячейку на нем, т.к. структуры листов одинаковые)
  Set rTo = Application.InputBox("Любая ячейка на листе вставки", "Запрос", Type:=8)
   
  ' Скопировать области только видимых ячеек диапазлна rFrom листа-источника
  For Each rArea In rFrom.SpecialCells(xlCellTypeVisible)
    rArea.Copy rTo.Worksheet.Range(rArea.Address)
  Next
  
exit_:
  
  If Err Then MsgBox Err.Description, vbExclamation, "Ошибка!"
  
End Sub

При этом в диалоге на листе, куда нужно копировать, можно указать любую ячейку, и фильтровать этот лист необязательно.
На листе-источнике можно сначала выделить то, что нужно копировать, и это попадет в диалог макроса.
 
 
 
#12
09.08.2022 11:40:32
пробуйте этот
Код
Sub PasteToVisible()
  Dim copyrng As Range, pasterng As Range, cell As Range, a&, c&
  'запрашиваем у пользователя по очереди диапазоны копирования и вставки
  Set copyrng = Application.InputBox("Диапазон копирования", "Запрос", Type:=8)
  Set pasterng = Application.InputBox("Диапазон вставки", "Запрос", Type:=8)
  If copyrng.Count <> pasterng.Count Then Exit Sub Else a = 1
  For Each cell In copyrng
    If pasterng.Areas(a).Cells.Count > c Then c = c + 1 Else a = a + 1: c = 1
    cell.Copy pasterng.Areas(a).Cells(c):   pasterng.Areas(a).Cells(c) = cell
  Next
End Sub

должно работать)
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!
 
 
 
#13
09.08.2022 18:45:15
Цитата
написал:
Sub PasteToVisible()  Dim copyrng As Range, pasterng As Range, cell As Range, a&, c&  'запрашиваем у пользователя по очереди диапазоны копирования и вставки  Set copyrng = Application.InputBox("Диапазон копирования", "Запрос", Type:=8)  Set pasterng = Application.InputBox("Диапазон вставки", "Запрос", Type:=8)  If copyrng.Count <> pasterng.Count Then Exit Sub Else a = 1  For Each cell In copyrng    If pasterng.Areas(a).Cells.Count > c Then c = c + 1 Else a = a + 1: c = 1    cell.Copy pasterng.Areas(a).Cells©:   pasterng.Areas(a).Cells© = cell  NextEnd Sub
Спасибо, все работает!
 
 
 
#14
09.08.2022 18:47:14
Цитата
написал:
пробуйте этот
Код
    [URL=#]?[/URL]       1  2  3  4  5  6  7  8  9  10  11      Sub   PasteToVisible()        Dim   copyrng   As   Range, pasterng   As   Range, cell   As   Range, a&, c&        'запрашиваем у пользователя по очереди диапазоны копирования и вставки        Set   copyrng = Application.InputBox(  "Диапазон копирования"  ,   "Запрос"  , Type:=8)        Set   pasterng = Application.InputBox(  "Диапазон вставки"  ,   "Запрос"  , Type:=8)        If   copyrng.Count <> pasterng.Count   Then   Exit   Sub   Else   a = 1        For   Each   cell   In   copyrng          If   pasterng.Areas(a).Cells.Count > c   Then   c = c + 1   Else   a = a + 1: c = 1          cell.Copy pasterng.Areas(a).Cells(c):   pasterng.Areas(a).Cells(c) = cell        Next    End   Sub  
 
должно работать)
Этот макрос работает не совсем корректно, переносит не только видимые ячейки, но и те, что скрыты. Спасибо за помощь!
 
 
 
Страницы: 1
Наверх