Доброго здравия уважаемые форумчане! Решил облегчить труд коллег лесного хоз-ва, но застрял в создании макроса для вставки картинки. Есть ексель документ для составления договоров купли-продажи с местным населением. В этом документе присутствует 3 листа "ФОРМА"; "ДОГОВОР К-П"; "РЕЕСТР". На листе "ФОРМА" внизу страницы, есть кнопочка "Вставить АБРИС". Именно к этой кнопке и нужно применить макрос для выбора картинки из папки (вручную нужно выбрать какую картинку) и вставки её на лист "ДОГОВОР К-П" на 4 страницу в ячейку B238. Картинки с абрисами имеют размер 15х15 см. Макрос требуется для того, чтоб коллеги не сбили формулы присутствующие в самом договоре. Очень надеюсь на помощь или подсказку для решения данной задачи! Прикладываю файл оригинал. Заранее Благодарю!
Доброго здравия уважаемые форумчане! Решил облегчить труд коллег лесного хоз-ва, но застрял в создании макроса для вставки картинки. Есть ексель документ для составления договоров купли-продажи с местным населением. В этом документе присутствует 3 листа "ФОРМА"; "ДОГОВОР К-П"; "РЕЕСТР". На листе "ФОРМА" внизу страницы, есть кнопочка "Вставить АБРИС". Именно к этой кнопке и нужно применить макрос для выбора картинки из папки (вручную нужно выбрать какую картинку) и вставки её на лист "ДОГОВОР К-П" на 4 страницу в ячейку B238. Картинки с абрисами имеют размер 15х15 см. Макрос требуется для того, чтоб коллеги не сбили формулы присутствующие в самом договоре. Очень надеюсь на помощь или подсказку для решения данной задачи! Прикладываю файл оригинал. Заранее Благодарю!Кузьмич
Как-то так можно. Только путь свой поставьте. [vba]
Код
Sub tt() ' On Error Resume Next With Application.FileDialog(msoFileDialogOpen) .InitialFileName = "D:\прикол\" 'если картинки в той же папке, что и файл, то = ThisWorkbook.Path & "\" If .Show <> -1 Then Exit Sub ppp_ = .SelectedItems(1) End With Set kar_ = Sheets("ДОГОВОР К-П").Range("A1").Parent.Pictures.Insert(ppp_) With Sheets("ДОГОВОР К-П").Range("B238") kar_.Top = .Top kar_.Left = .Left End With End Sub
[/vba]
Как-то так можно. Только путь свой поставьте. [vba]
Код
Sub tt() ' On Error Resume Next With Application.FileDialog(msoFileDialogOpen) .InitialFileName = "D:\прикол\" 'если картинки в той же папке, что и файл, то = ThisWorkbook.Path & "\" If .Show <> -1 Then Exit Sub ppp_ = .SelectedItems(1) End With Set kar_ = Sheets("ДОГОВОР К-П").Range("A1").Parent.Pictures.Insert(ppp_) With Sheets("ДОГОВОР К-П").Range("B238") kar_.Top = .Top kar_.Left = .Left End With End Sub
Друже, всё работает как надо. Есть небольшой нюанс, картинки накладываются одна на другую. Возможно ли немного изменить? Применить функцию "заменить рисунок" - он заменяет исходный рисунок на новый. У меня мозгов не хватит это сделать.
Друже, всё работает как надо. Есть небольшой нюанс, картинки накладываются одна на другую. Возможно ли немного изменить? Применить функцию "заменить рисунок" - он заменяет исходный рисунок на новый. У меня мозгов не хватит это сделать.Кузьмич
Sub tt() ' On Error Resume Next With Application.FileDialog(msoFileDialogOpen) .InitialFileName = "D:\прикол\" 'если картинки в той же папке, что и файл, то = ThisWorkbook.Path & "\" If .Show <> -1 Then Exit Sub ppp_ = .SelectedItems(1) End With Sheets("ДОГОВОР К-П").DrawingObjects.Delete 'Удаляет все объекты на листе Set kar_ = Sheets("ДОГОВОР К-П").Range("A1").Parent.Pictures.Insert(ppp_) With Sheets("ДОГОВОР К-П").Range("B238") kar_.Top = .Top kar_.Left = .Left End With End Sub
[/vba]
Так? [vba]
Код
Sub tt() ' On Error Resume Next With Application.FileDialog(msoFileDialogOpen) .InitialFileName = "D:\прикол\" 'если картинки в той же папке, что и файл, то = ThisWorkbook.Path & "\" If .Show <> -1 Then Exit Sub ppp_ = .SelectedItems(1) End With Sheets("ДОГОВОР К-П").DrawingObjects.Delete 'Удаляет все объекты на листе Set kar_ = Sheets("ДОГОВОР К-П").Range("A1").Parent.Pictures.Insert(ppp_) With Sheets("ДОГОВОР К-П").Range("B238") kar_.Top = .Top kar_.Left = .Left End With End Sub
То что нужно! Чтобы радостно и мудро жили люди на Руси, Продолжай святое дело с честью бороду носи! Чтобы помощь славных предков не прервалась никогда, Помогает в этом деле несомненно Boroda
То что нужно! Чтобы радостно и мудро жили люди на Руси, Продолжай святое дело с честью бороду носи! Чтобы помощь славных предков не прервалась никогда, Помогает в этом деле несомненно Boroda
Благодарю друже от души! Низкий тебе поклон!Кузьмич
Вход
Регистрация
Напомнить пароль
Автосумма
Часто используемые
ВПР
ЕСЛИ
СУММЕСЛИ
Финансовые
Логические
Текстовые
Даты и времени 
Ссылки и массивы 
Математические
Другие функции
Проверка свойств и значений
Баз данных
Математические
Обработки массивов
Обработки строк
Преобразования типов данных 
Загрузки данных
Работы с файлами
Обработки системных параметров
Обработки цвета
Работы с датами и временем
Преобразования в системы счисления
Финансовые
