Вставка картинок и изображений в ячейки листа Excel

Попробовал сегодня вставить макрос, который с PicRange, в свой файл в Экселе 2007.
Картинка не пожелала выравниваться по ячейке непропорционально. Выравнивает либо по высоте либо по ширине,в зависимости от того, что раньше сработает. одновременно выоту и ширину не подгоняет. Видимо нужно юзать Shapes, так как Pictures устарел. Искать помощь времени не было, посему заюзал по быстрому надстройку. Текущую задачу решил, спасибо.

Здравствуйте, с помощью какой функции можно отследить такое событие как вставка картинки в excel? То есть моя задача состоит в том чтобы макрос запускался по факту вставления картинки в excel пользователем.

Спасибо.

Подскажите, пожалуйста, а как можно копировать рисунок из одной ячейки в другую.
Например, конкретно из ячейки B2 в ячейку E5?

Спасибо,
очень помогли!

Нашел, вы даете ссылку на надстройку (http://excelvba.ru/programmes/PastePictures).
А там не указан код, только ссылка для скачивания.
Хотелось бы увидеть способ реализации.
Можно?

Подскажите, пожалуйста, как можно сделать, чтобы рисунок вставлялся в Excel не как ссылка, а как рисунок.
Дело в том, что при данной вставке, если рисунок из папки удалить, то он не будет виден в Excel ...

Здравствуйте, а возможна ли данная реализация для подтягивания графиков из ексель, в презентацию поверпоинт? Попробовал самостоятельно разработать, вышло следующее:

' Импортирует все графики в презентацию
Dim counter As Long
 
Sub ImportGraphs()
    Dim fileName As String
    Dim i
 
    Dim xlApp As Object
    Dim xlWorkbook As Object
    Dim xlSheet As Object
 
    Set xlApp = CreateObject("Excel.Application")
 
    fileName = xlApp.GetOpenFilename("Excel Files (*.xls), *.xls")
 
    If fileName Like "" Then
    MsgBox ("Выберите файл для импортирования данных")
    Else
    xlApp.Workbooks.Open (fileName)
 
    Set xlWorkbook = xlApp.ActiveWorkbook
    xlApp.Visible = True
 
    counter = 1
 
    For Each xlSheet In xlWorkbook.Sheets
      If xlSheet.Name Like "Диаграмма*" Then
          xlSheet.ChartArea.Copy
          PasteGraphs
        Else
         If xlSheet.ChartObjects.Count > 0 Then
           For i = 1 To xlSheet.ChartObjects.Count
             xlSheet.ChartObjects(i).Chart.ChartArea.Copy
             PasteGraphs
           Next
         End If
 
       End If
    Next
 
    End If
 
    Set xlWorkbook = Nothing
    xlApp.Quit
    Set xlApp = Nothing
End Sub
 
Sub PasteGraphs()
   ActivePresentation.Slides.Add(Index:=counter, Layout:=ppLayoutBlank).Select
   ActiveWindow.Panes(2).Activate
   ActiveWindow.View.PasteSpecial ppPasteOLEObject, , , , , msoTrue
   '
   ' изменение размера вставленного объекта
    With ActiveWindow.Selection.ShapeRange
        .ScaleWidth 1, msoFalse, msoScaleFromBottomRight
        .ScaleHeight 1, msoFalse, msoScaleFromBottomRight
        .ScaleWidth 1, msoFalse, msoScaleFromTopLeft
        .ScaleHeight 1, msoFalse, msoScaleFromTopLeft
    End With
    counter = counter + 1
End Sub

Все работает отлично, но вот хотелось бы доработать автоподбор размера графика, к примеру если диаграмма небольшого размера, то в один слайд по возможности вставлялось несколько диаграмм.
Буду рад советам и благодарен за помощь + возможно так же кому то пригодится.

здравствуйте помогите пожалуйста!. воспользовался вашим продуктом поиска файлов в папке и подпапках. очень помог в решении задач.
возможно ли в продолжении функционала вставку картинок в список файлов который находит ваш макрос. т.е. хочу сделать автоматически через userform. если возможно с пояснениями. спасибо!

Я в Excel не особый знаток, мне как раз нужен макрос по вставке фото в лист. Но я не знаю как отредактировать Ваш макрос. Т.е. там многое написано по-русски (не учитывая комментарии). Если просто вставить ваш код в исходный код Excel, то ничего не работает. Помогите пожалуйста разобраться! Спасибо!

Спасибо большое! Буду пробовать

Спасибо большое! Я к сожалению не обладаю особыми знаниями, чтобы изменять и подстраивать команды...
Вашей программой с надстройками я уже успешно пользуюсь, но все же мне хочется упростить процесс нажатием горячих клавиш.
Не могли бы Вы мне еще подсказать команду для сжатия вставляемой фотографии?

Доброго времени суток!
Помогите мне пожалуйста с макросом. Данный макрос прекрасно работает в Excel 2003, но в 2010-м Excel все не так, при переносе файла в ячейках вылетают ссылки. Помогите пожалуйста адаптировать данный код под 2010 Excel

    PicLocation = Application.GetOpenFilename("Image Files (*.jpg),*.jpg", , "Select Image File", , "False")
    ActiveSheet.Pictures.Insert(PicLocation).Select
    Selection.ShapeRange.ScaleWidth 0.12, msoFalse, msoScaleFromTopLeft
    Selection.ShapeRange.ScaleHeight 0.12, msoFalse, msoScaleFromTopLeft

Здравствуйте. Мне не помог метод AddPicture с нулями. Файл по-прежнему большой создается. Возможно ли заказать у Вас изменение этого макроса, так, чтобы картинки вставлялись не ссылками и ужимались? Так, как это делает Ваша надстройка? И сколько это стоить будет?

Да, я все из 1С делаю. Когда выводила прайс с помощью AddPicture, получался файл 6 метров, когда заполняла картинки того же файла с помощью вашей надстройки - 3 метра.
Вообще использовала AddPicture с параметрами сразу установленными, попробую с нулями. Большое спасибо за ответы! А то я ни разу не VBA-программист.

Да, программа хорошо вставляет) Но мне нужно формировать файл и отсылать клиентам по кнопочке, чтобы пользователи даже не заходили в Excel. Я еще пробовала метод AddPicture, но файл большой получается, он, видимо, не сжимает картинку при вставке. Т.е. не судьба, или можно еще что-то попробовать?

Здравствуйте! Я использовала Ваш макрос для вывода картинок из 1с в Excel. Но при удалении каталога с картинками вместо картинок отображается сообщение "Не удается отобразить связанный рисунок". А мне нужно файл клиентам отсылать. Что я не так делаю? Подскажите, пожалуйста!

Подскажите, пожалуйста.
Если файл Excel является общим, как тогда вставлять картинку?
Посредством данной функции вставка не происходит.

как уменьшить текс в exele и копировать в word

Здравствуйте,
можете ли подсказать какими макрокомандами можно менять положение желтого ромбика на вставленный кубик? (msoShapeCube)

Здравствуйте,
хотела, чтобы картинка менялась в цикле, но получается только в конце цикла картинка отображает последний путь, а во время цикла не меняется

x = 0
While x < 21
Sheet7.Activate
a = Лист2.Cells(2 + x, 2)
Sheet7.Cells(4, 6).Value = a
Sheet7.Cells(4, 10).Value = Лист2.Cells(2 + x, 3)
curfolder = current
p = ActiveWorkbook.Path & "\img\" & a & ".jpg"
Sheet7.Cells(4, 25).Value = p
p2 = ActiveWorkbook.Path & "\img\no.jpg"
If Dir(p, vbDirectory) <> "" Then
Sheet7.Image1.Picture = LoadPicture(p)
Else:
Sheet7.Image1.Picture = LoadPicture(p2)
End If

Sheet7.Cells(5 + x, 1).Value = Dir(p, vbDirectory)
x = x + 1
Application.Wait Now() + TimeValue("00:00:01")
Wend

Подскажите пожалуйста, можно ли как проверить была ли вставлена картинка методом ActiveSheet.Pictures.Insert или же нет? Возможно проще проверить существует ли файл с фотографией перед ее вставкой? Способ так же мне неизвестный. Просветите пожалуйста...

Спасибо большое администратору за оказанную помощь!!! Но у меня есть еще маленький вопросик:
у меня есть такой код (см. ниже) который из ячейки D3 берет значение пути к картинке (путь к картинке проставляется внешней программой) и вставляет картинку в ячейку E3. При чем вставляет в левый верхний угол.

1) Из этой статьи не совсем разобрался как сделать в моем коде так, чтобы ячейка принимала размер картинки, но чтобы картинки больше 100 на 50 пикселей сжимались до этого размера, и только после этого ячейка могла бы принять размер картинки.

2) Как мне оптимизировать этот код, чтобы макрос определял, какие ячейки в колонке D заполнены (например с 3 по 15 или с 3 по 26) и заполнял картинками колонку E тоже с 3 по 15 или с 3 по 26 соответственно?

With ActiveSheet.Pictures.Insert([D3])
.Top = [E3].Top
.Left = [E3].Left
.Name = [E3]
End With

Я только что направил Вам проект ТЗ о витринах и прилавках.
К ТЗ приложен файл "ИД.Витрина...". В нем динамически меняющиеся раскрывающиеся списки, меняющееся изображение витрины (выполнено в полном соответствии с Вашими рекомендациями), условное форматирование и подсказки "для защиты от дурака". Над размерными линиями надо проставить размеры из таблицы, но ячейки под рисунком не видны (рис.не прозрачный), а текстовое поле НЕ УДАЕТСЯ ПОВЕРХ НЕГО поставить. Почему? - не понимаю... (Ведь, если действовать через меню Вставить/Рисунок, то удается текстовое поле поставить поверх рисунка).

Прим.: В "ИД.Витрина..." управление раскрывающимися списками и условным форматированием осуществляется с скрытого листа.

Поступил как указано в Ответе #26...
Мой файл при этом "потолстел" в 10 раз (с 506КБ, до 61000КБ).
Так не должно быть.
Прим.: вставляемая в Image2 картинка вести 3900КБ.

Действительно, "всё гениальное просто".
Спасибо!!! Стыдно, но деваться не куда, буду краснеть дальше....
Возникла еще одна проблемка:
Я хотел поверх Image1 (изменяющиеся изображения витрин в зависимости от выбранного в раскрывающ.списке) поместить меняющиеся надписи -габаритные размеры (TextBox), связав их с значениями в ячейках. Однако, не удается поместить эти TextBox над Imege1. Из меню под правой кнопкой мыши не удается выполнить ни "На передний план", ни "На задний план".
Как поступить?

Спасибо еще раз! Макрос и процедура работают замечательно!
Но... Захотелось по аналогии пристегнуть сменяющиеся картинки еще к одному раскрывающемуся списку и обломился. Не пойму почему. Подскажите - где ошибка?

Sub ОбновлениеКартинкиВитрины()
On Error Resume Next
Set [Image1].Object.Picture = Nothing
Set [Image1].Object.Picture = LoadPicture([Место_хранения_рисунка_витрины])
End Sub

Sub ОбновлениеКартинкиСтоек()
On Error Resume Next
Set [Image2].Object.Picture = Nothing
Set [Image2].Object.Picture = LoadPicture([Место_хранения_рисунка_стойки])
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, [AE22:AE23]) Is Nothing Then ОбновлениеКартинкиВитрины
End Sub

Private Sub Worksheet_Ch(ByVal Target As Range)
If Not Intersect(Target, [AE26:AE26]) Is Nothing Then ОбновлениеКартинкиСтоек
End Sub

Макрос "Обновление картинки стоек" работает, но процедура, привязанная к изменению в ячейке AE26 не запускается. Почему?

СУППЕРРР!
Спасибо громадное!
Подскажите, где можно поучиться VBA для Exel в СПб?

Огромное С П А С И Б О!!!

..И тут же получу сообщение " Для условий "Проверка данных" нельзя использовать ссылки на другие листы"

Как сделать ввод фирм в таблицу со списком, если список фирм расположен на другой странице?
(данные\проверка\список...)?