Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
Вырезание-вставка всех рисунков по очереди VBA
 
#1
22.01.2016 11:31:24
Есть столбец в каждой ячейке кроме 1-й есть рисунок, каждый рисунок прикреплен как связь, требуется вставить рисунок (именно "Вставкой" - добавить в тело файла). В VBA мало понимаю, но записав макрос с вырезанием и вставкой одного рисунка получил:
Код
Sub Макрос1()
    ActiveSheet.Shapes.Range(Array("Рисунок 2")).Select
    Selection.Cut
    Range("G2").Select
    ActiveSheet.Pictures.Paste.Select
End Sub
но не знаю как теперь переходить к следующему рисунку автоматом.... подскажите как можно это выполнить. Все картинки также находятся в столбце G со второй ячейки.
Изменено: airfox - 22.01.2016 11:42:43
 
 
 
#2
22.01.2016 12:16:29
Проверить не на чем. Файла-примера нет
Код
Sub Макрос1()
lRow = Cells(Rows.Count, "G").End(xlUp).Row
For I = 2 To lRow
    With ActiveSheet
        .Shapes.Range(Array("Рисунок " & I)).Cut
        .Range("G" & I).Select
        .Pictures.Paste.Select
    End With
Next
End Sub
Согласие есть продукт при полном непротивлении сторон
 
 
 
#3
22.01.2016 12:19:47
вот файл примера, требуется изменить связь на свое изображение
Изменено: airfox - 22.01.2016 14:07:39
 
 
 
#4
22.01.2016 13:09:56
не работает к сожалению
 
 
 
#5
22.01.2016 13:21:56
Цикл вообще не нужен:
Код
Sub CopyPics()
    ActiveSheet.DrawingObjects.Copy
    ActiveSheet.Paste
End Sub
Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы...
 
 
 
#6
22.01.2016 13:27:02
Хотя, как я помню - старые картинки необходимо же удалить после копирования? Значит скорее подойдет такой код:
Код
Sub CopyPics()
    Dim oSh As Shape
    Dim arr(), i As Long
    
    ReDim arr(0 To ActiveSheet.Shapes.Count - 1)
    For Each oSh In ActiveSheet.Shapes
        arr(i) = oSh.Name
        i = i + 1
    Next
    ActiveSheet.Shapes(1).TopLeftCell.Select
    ActiveSheet.DrawingObjects.Copy
    ActiveSheet.Paste
    ActiveSheet.Shapes.Range(arr).Delete
End Sub
Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы...
 
 
 
#7
22.01.2016 13:39:45
Цитата
The_Prist написал:
ActiveSheet.Paste
Требуется именно ActiveSheet.Pictures.Paste.Select, так как таким способом мы помещаем рисунки в тело файла, по вашему примеру получается как я понял выделить все объекты и вставить как есть.., если поменять ActiveSheet.Paste на  ActiveSheet.Pictures.Paste.Select склеваем все рисунки в один, так не подходит
Изменено: airfox - 22.01.2016 14:05:41
 
 
 
#8
22.01.2016 13:47:08
airfox, объясните, пожалуйста, последний оператор из кода в Вашей цитате:

Где-то я встречал такой... :)
 
 
 
#9
22.01.2016 13:54:08
ActiveSheet.Paste как я понимаю просто выполняет ctrl+v, вставляя просто связь, так как картинки вставлены как связь, а ActiveSheet.Pictures.Paste.Select - специальная вставка рисунка, которая заставляет запихать рисунок во внутрь файла xls  
 
 
 
#10
22.01.2016 13:59:16
Цитата
airfox написал:
как я понимаю
Вы не пробовали код-то выполнить на реальном файле? Все на догадках? Или уже опробовали? Просто если Вы догадки за реальность выдаете - зачем нам пытаться дальше что-то изобретать, чтобы дать решение, которое устроит Вас исключительно по Вашим догадкам, а не по реальному выполнению задачи?
Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы...
 
 
 
#11
22.01.2016 14:01:40
проверял, там сверху есть файл, при выполнении макроса, который вы предложили, путем его сохранения как xlsx, внутри него нет рисунков.
У Вас получилось? теперь дошло я то высылаю файл в котором будут указаны связи, рисунков Вы не увидите... поправьте связи на какое нибудь свое изображение и выполните макрос, пожалуйста
Изменено: airfox - 22.01.2016 14:04:07
 
 
 
#12
22.01.2016 14:02:47
А откуда они у меня будут? Они у меня вообще никаким копированием не отображаются. Ни ручным, ни макросом. Потому что у них нет вообще связи с реальными ссылками.
Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы...
 
 
 
#13
22.01.2016 14:02:55
airfox, последний оператор в Вашей цитате - The_Prist :)
Обратил Ваше внимание на то, что цитировать нужно осмысленно. а Вы не поняли намека.
 
 
 
#14
22.01.2016 14:05:12
понял vikttur, The_Prist поправьте связи на какое нибудь свое изображение и выполните макрос, пожалуйста


The_Prist давайте я попытаюсь объяснить более понятно, в документе находится прайс с товарами, создан столбец в котором находятся рисунки на против каждой строки с товаром, данные рисунки отображаются при помощи связи. Требуется при выполнении макроса заменить связи на привязку рисунков по связям к телу файла, единственное решение которое мною было найдено это специальная вставка рисунка. Не много покопавшись понял что есть еще один способ привязать рисунки...

первый столбец таблицы содержит названия файлов изображений, может есть способ экспортировать изображения?
Изменено: airfox - 22.01.2016 14:25:02
 
 
 
#15
22.01.2016 14:28:58
Так не вижу проблем сделать цикл на основе предложенных решений:
Код
Sub CopyPics()
    Dim oSh As Shape
    Dim arr(), i As Long
    
    ReDim arr(0 To ActiveSheet.Shapes.Count - 1)
    For Each oSh In ActiveSheet.Shapes
        arr(i) = oSh.Name
        i = i + 1
        oSh.Copy
        oSh.TopLeftCell.Select
        ActiveSheet.Pictures.Paste
    Next
    ActiveSheet.Shapes.Range(arr).Delete
End Sub
Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы...
 
 
 
#16
22.01.2016 14:38:31
так вот не получалось понять как именно написать этот самый цикл  :D
Спасибо огромное Вам за помощь!!!  
 
 
 
Страницы: 1
Читают тему
Наверх