Vba excel вставка рисунка

Хитрости »

6 Февраль 2020              22727 просмотров

Вставить картинку в лист — по списку или выбору из ячейки

Сама по себе задача вставки картинки на листе не сложная и ответ лежит на поверхности: это доступно прямо из меню: Вставка(Insert) -группа Иллюстрации(Illustrations) —Рисунок(Picture):

Кодом VBA вставить тоже не сложно, даже макрорекордер записывает это действие:

Sub InsertPicture()
    ActiveSheet.Pictures.Insert("G:ДокументыИзображенияExcel_vba_ru.png"). _
        Select
End Sub

Но что делать, если вставить надо картинку из заранее известной папки, но с изменяющимся именем? А если при этом еще надо не просто вставить — а подогнать размер картинки под размер ячейки? Например, в ячейке А2 название товара(соответствует названию картинки), а в В2 должно быть изображение. Здесь уже посложнее. Но тоже вполне реализуемо при помощи VBA

'---------------------------------------------------------------------------------------
' Author : The_Prist(Щербаков Дмитрий)
'          Профессиональная разработка приложений для MS Office любой сложности
'          Проведение тренингов по MS Excel
'          https://www.excel-vba.ru
'          info@excel-vba.ru
'          WebMoney - R298726502453; Яндекс.Деньги - 41001332272872
' Purpose: вставка в ячейку картинки с подгонкой под размеры ячейки
'---------------------------------------------------------------------------------------
Sub InsertPicToCell()
    'путь к папке с картинками
    Const sPicsPath As String = "G:ДокументыИзображения"
    Dim sPicName As String, sPFName As String, sSpName As String
    Dim oShp As Shape
    Dim zoom As Double
 
    'в этой ячейке выпадающий список с именами картинок
    sPicName = Range("A2").Value
    'если имя картинки не задано
    If sPicName = "" Then
        Exit Sub
    End If
    'проверяем наличие картинки в папке
    sPFName = sPicsPath & sPicName
    If Dir(sPFName, 16) = "" Then
        Exit Sub
    End If
    'в эту ячейку вставляем картинку
    With Range("B2")
        On Error Resume Next
        'задаем картинке уникальный адрес,
        'привязанный к адресу ячейки
        sSpName = "_" & .Address(0, 0) & "_autopaste"
        'если картинка уже есть - удаляем её
        Set oShp = ActiveSheet.Shapes(sSpName)
        If Not oShp Is Nothing Then
            oShp.Delete
        End If
        'вставляем выбранную картинку
        Set oShp = ActiveSheet.Shapes.AddPicture(sPFName, False, True, .Left + 1, .Top + 1, -1, -1)
        'определяем размеры картинки в зависимости от размера ячейки
        zoom = Application.Min(.Width / oShp.Width, .Height / oShp.Height)
        oShp.Height = oShp.Height * zoom - 2
        'переименовываем вставленную картинку(чтобы потом можно было заменить)
        oShp.Name = sSpName
    End With
End Sub

Чтобы использовать код необходимо создать в книге стандартный модуль(переходим в редактор VBA(Alt+F11) —Insert —Module) и вставить в него приведенный выше код. Чтобы картинка вставилась в ячейку, надо записать имя картинки в ячейку A2, нажать сочетание клавиш Alt+F8 и выбрать макрос InsertPicToCell. Не очень удобно, правда?
Значит теперь попробуем сделать так, чтобы при каждом изменении в А2 картинка менялась сама, без необходимости запускать каждый раз код вручную. Для этого придется использовать возможность Excel отслеживать такие события, как изменения ячейки(чтобы лучше понять где это лучше сразу прочитать статью Что такое модуль? Какие бывают модули? и особое внимание уделить описанию про модули листов). Теперь чуть переделываем код:

Private Sub Worksheet_Change(ByVal Target As Range)
'---------------------------------------------------------------------------------------
' Author : The_Prist(Щербаков Дмитрий)
'          Профессиональная разработка приложений для MS Office любой сложности
'          Проведение тренингов по MS Excel
'          https://www.excel-vba.ru
'          info@excel-vba.ru
'          WebMoney - R298726502453; Яндекс.Деньги - 41001332272872
' Purpose: вставка в ячейку картинки с подгонкой под размеры ячейки
'---------------------------------------------------------------------------------------
    'путь к папке с картинками
    Const sPicsPath As String = "G:ДокументыИзображения"
    Dim sPicName As String, sPFName As String, sSpName As String
    Dim oShp As Shape
    Dim zoom As Double
    'т.к. список с именами картинок у нас в ячейке А2,
    'то определяем, что значение изменилось именно в ней
    '   если в ячейке А2 имена картинок, а список товара в другой ячейке
    '   то надо заменить А2 на ту, которая изменяется списком или руками
    If Intersect(Target, Range("A2")) Is Nothing Then
        'изменения не в А2 - ничего не делаем, завершаем код
        Exit Sub
    End If
    'в этой ячейке выпадающий список с именами картинок
    sPicName = Range("A2").Value
    'если имя картинки не задано
    If sPicName = "" Then
        Exit Sub
    End If
    'проверяем наличие картинки в папке
    sPFName = sPicsPath & sPicName
    If Dir(sPFName, 16) = "" Then
        Exit Sub
    End If
    'в эту ячейку вставляем картинку
    With Range("B2")
        On Error Resume Next
        'задаем картинке уникальный адрес,
        'привязанный к адресу ячейки
        sSpName = "_" & .Address(0, 0) & "_autopaste"
        'если картинка уже есть - удаляем её
        Set oShp = ActiveSheet.Shapes(sSpName)
        If Not oShp Is Nothing Then
            oShp.Delete
        End If
        'вставляем выбранную картинку
        Set oShp = ActiveSheet.Shapes.AddPicture(sPFName, False, True, .Left + 1, .Top + 1, -1, -1)
        'определяем размеры картинки в зависимости от размера ячейки
        zoom = Application.Min(.Width / oShp.Width, .Height / oShp.Height)
        oShp.Height = oShp.Height * zoom - 2
        'переименовываем вставленную картинку(чтобы потом можно было заменить)
        oShp.Name = sSpName
    End With
End Sub

Теперь переходим на лист, где в А2 будет изменяться название картинки -правая кнопка мыши на этом листе —Посмотреть код(View Code). Вставляем код выше. Все, теперь при любом изменении в А2 картинка будет изменяться(если указанный файл будет найден в нужной папке).
Если картинки расположены не в «G:ДокументыИзображения», а в той же папке, что и сама книга с кодом, достаточно эту строку
Const sPicsPath As String = «G:ДокументыИзображения»
заменить такими
Dim sPicsPath As String
sPicsPath = ThisWorkbook.Path & «»
тогда папка с книгой будет определяться автоматически.
Но я понимаю, что куда правильнее в ячейке А2 при помощи выпадающего списка выбирать наименование товара, а в В2 при помощи функции ВПР(VLOOKUP) подтягивать из справочника название картинки и уже по этому названию вставлять картинку. Но подстроить код под это уже не сложно. Приводить его здесь не буду, т.к. можно будет запутаться с описанием списка, функций, где и что. Тем более что сам код практически не отличается. К тому же именно в этой реализации код есть в приложенном к статье файле.
Скачать файл:

  Вставить картинку в ячейку (366,9 KiB, 2 392 скачиваний)

И еще часто встречающаяся задача по вставке картинок — это вставка картинок массово. Т.е. вставить картинки на основании значений, записанных в столбце. В данном случае это столбец В. А вставлять картинки будем в столбец С, подгоняя размеры картинок под размер каждой ячейки и проверяя, не вставляли ли мы эту картинку туда ранее

Впрочем, основная часть кода была приведена выше — здесь мы лишь добавим цикл по ячейкам. Так же в этом коде мы используем диалог выбора папки, в котором просматривать картинки:

'---------------------------------------------------------------------------------------
' Author : The_Prist(Щербаков Дмитрий)
'          Профессиональная разработка приложений для MS Office любой сложности
'          Проведение тренингов по MS Excel
'          https://www.excel-vba.ru
'          info@excel-vba.ru
'          WebMoney - R298726502453; Яндекс.Деньги - 41001332272872
' Purpose: вставка в ячейку картинки с подгонкой под размеры ячейки
'---------------------------------------------------------------------------------------
Option Explicit
 
Sub InsertPictureByVal()
    Dim sPicsPath As String
    Dim sPicName As String, sPFName As String, sSpName As String
    Dim llastr As Long, lr As Long
    Dim oShp As Shape
    Dim zoom As Double
 
    'выбираем путь к папке с картинками
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Выбрать папку с картинками"       'заголовок окна диалога
        .ButtonName = "Выбрать папку"
        .Filters.Clear                              'очищаем установленные ранее типы файлов
        .InitialFileName = ThisWorkbook.Path        'назначаем первую папку отображения
        .InitialView = msoFileDialogViewLargeIcons  'вид диалогового окна
        If .Show = 0 Then Exit Sub               'показываем диалог
        sPicsPath = .SelectedItems(1) 'считываем путь к папке
    End With
    '   если путь надо указать статичный - вместо диалога прописываем одну строку
    '   sPicsPath = "C:images"
 
 
    'проверяем, есть ли слеш после пути к папке
    'если нет - добавляем, иначе путь к картинке будет неверный
    If Right(sPicsPath, 1) <> Application.PathSeparator Then
        sPicsPath = sPicsPath & Application.PathSeparator
    End If
    'определяем последнюю ячейку по столбцу с именами картинок
    llastr = Cells(Rows.Count, 2).End(xlUp).Row
    'если кроме шапки в столбце с именами картинок ничего нет
    If llastr < 2 Then
        Exit Sub
    End If
    'цикл по столбцу с именами картинок
    For lr = 2 To llastr
        sPicName = Cells(lr, 2).Value
        'проверяем наличие картинки в папке
        sPFName = sPicsPath & sPicName
        If Dir(sPFName, 16) <> "" And sPicName <> "" Then
            'в эту ячейку вставляем картинку
            With Cells(lr, 3)
 
                'задаем картинке уникальный адрес,
                'привязанный к адресу ячейки
                sSpName = "_" & .Address(0, 0) & "_autopaste"
                'если картинка уже есть - удаляем её
                Set oShp = Nothing
                On Error Resume Next
                Set oShp = ActiveSheet.Shapes(sSpName)
                If Not oShp Is Nothing Then
                    oShp.Delete
                End If
                On Error GoTo 0
                'вставляем выбранную картинку
                Set oShp = ActiveSheet.Shapes.AddPicture(sPFName, False, True, .Left + 1, .Top + 1, -1, -1)
                'определяем размеры картинки в зависимости от размера ячейки
                zoom = Application.Min(.Width / oShp.Width, .Height / oShp.Height)
                oShp.Height = oShp.Height * zoom - 2
                'переименовываем вставленную картинку(чтобы потом можно было заменить)
                oShp.Name = sSpName
            End With
        End If
    Next
End Sub

Прикладываю пример в формате ZIP-архива, т.к. вместе с самим файлом с кодом я приложил папку images, которая содержит картинки, используемые для вставки в файле. Папка images и сам файл с кодом должны быть распакованы в одну папку.
Скачать файл:

  Вставить картинку в ячейку (366,9 KiB, 2 392 скачиваний)

Обратная задача — сохранение картинок из листа — уже разбиралась мной в этой статье: Как сохранить картинки из листа Excel в картинки JPG

Так же см.:
Как сохранить картинки из листа Excel в картинки JPG
При вставке из VBA картинки на лист ошибка «Метод paste из класса worksheet завершен неверно»
Как скопировать картинку из примечания?
Копирование картинки из примечания

Статья помогла? Поделись ссылкой с друзьями!

    Видеоуроки

Поиск по меткам



Access
apple watch
Multex
Power Query и Power BI
VBA управление кодами
Бесплатные надстройки
Дата и время
Записки
ИП
Надстройки
Печать
Политика Конфиденциальности
Почта
Программы
Работа с приложениями
Разработка приложений
Росстат
Тренинги и вебинары
Финансовые
Форматирование
Функции Excel
акции MulTEx
ссылки
статистика

While it is not often that we have to control pictures or images within Excel, based on the number of Google searches for this topic, it’s clearly something people want to know more about. This post serves as a reference to cover most of the scenarios we’re likely to encounter to copy, insert, move, delete and control pictures.

This code can be used in conjunction with my post about using a user defined function to insert and change pictures based on a cell value, which can be found here: https://exceloffthegrid.com/automatically-change-picture/

Download the example file

I recommend you download the example file for this post.  Then you’ll be able to work along with examples and see the solution in action, plus the file will be useful for future reference.

Download the file: 0042 VBA copy insert, move, delete pictures.zip

Adapting the code to your needs

It is unlikely that any of the codes will meet your exact requirements. Every code snippet uses variables to hold either the image, the worksheet, a range or an object.  By changing those variables, the code can easily be changed and combined with other code snippets to meet your specific requirements.

Insert an image into a worksheet

The following code will insert an image into the active cell of the active worksheet, keeping the original image’s size.

Sub InsertImage()

Dim ws As Worksheet
Dim imagePath As String
Dim imgLeft As Double
Dim imgTop As Double

Set ws = ActiveSheet
imagePath = "C:UsersmarksDocumentsmyImage.png"
imgLeft = ActiveCell.Left
imgTop = ActiveCell.Top

'Width & Height = -1 means keep original size
ws.Shapes.AddPicture _
    fileName:=imagePath, _
    LinkToFile:=msoFalse, _
    SaveWithDocument:=msoTrue, _
    Left:=imgLeft, _
    Top:=imgTop, _
    Width:=-1, _
    Height:=-1
 
End Sub

Depending on our needs, it may be better to create an image straight into an object variable.  Then we can refer to the image by using the variable and do not need to know the name of the image.  The following code is an example of this technique.

Sub InsertImageToDeclaredVariable()

Dim myImage As Shape
Dim ws As Worksheet
Dim imagePath As String
Dim imgLeft As Double
Dim imgTop As Double

Set ws = ActiveSheet
imagePath = "C:UsersmarksDocumentsmyImage.png"
imgLeft = ActiveCell.Left
imgTop = ActiveCell.Top

Set myImage = ws.Shapes.AddPicture( _
    Filename:=imagePath, _
    LinkToFile:=msoFalse, _
    SaveWithDocument:=msoTrue, _
    Left:=imgLeft, _
    Top:=imgTop, _
    Width:=-1, _
    Height:=-1)

'Use the variable for the created image
MsgBox myImage.Name

End Sub

Image names

The code below will display the name of the last inserted image.

The message box is to illustrate that the code works.  Once we have captured the shape as an object in the real world, we would perform other actions on the shape.

Sub GetNameOfLastInsertedImage()

Dim myImage As Shape

Set myImage = ActiveSheet.Shapes(ActiveSheet.Shapes.Count)

MsgBox myImage.Name

End Sub

The code below renames an existing image.

Sub RenameImage()

Dim myImage As Shape
Dim ws As Worksheet

Set ws = ActiveSheet
Set myImage = ws.Shapes("Picture 2")

myImage.Name = "New Image Name"

End Sub

Get image properties

The following code demonstrates how to retrieve common image properties

Sub GetImageProperties()

Dim myImage As Shape
Dim ws As Worksheet

Set ws = ActiveSheet
Set myImage = ws.Shapes("Picture 1")

MsgBox "Top: " & myImage.Top & vbNewLine & _
    "Left: " & myImage.Left & vbNewLine & _
    "Width: " & myImage.Width & vbNewLine & _
    "Height: " & myImage.Height & vbNewLine & _
    "Z-Order: " & myImage.ZOrderPosition & vbNewLine & _
    "Name: " & myImage.Name & vbNewLine & _
    "Top Left Cell: " & myImage.TopLeftCell & vbNewLine

End Sub

Delete an image

The following code will delete an image called Picture 1 from the active worksheet.

Sub DeleteImage()

Dim myImage As Shape
Dim ws As Worksheet

Set ws = ActiveSheet
Set myImage = ws.Shapes("Picture 1")

myImage.Delete

End Sub

Make images invisible

Images can be made invisible.  They still exist and are part of the workbook, but they are not visible to the user.

Sub MakeImageInvisible()

Dim myImage As Shape
Dim ws As Worksheet

Set ws = ActiveSheet
Set myImage = ws.Shapes("Picture 1")

myImage.Visible = msoFalse

'Make the image visible again
'myImage.Visible = msoTrue

End Sub

Loop through all images on a worksheet

The following code will loop through all the images on the active sheet.

Sub LoopThroughImagesOnWs()

Dim shp As Shape
Dim ws As Worksheet

Set ws = ActiveSheet

For Each shp In ws.Shapes

    If shp.Type = msoPicture Then
 
        'Do something to the image
        'Example, show message box
        MsgBox shp.Name & " is a picture"
 
    End If

Next shp

End Sub

Delete an image

The code below will delete a specific named picture.

Sub DeletePicture()

Dim myImage As Shape

Set myImage = ActiveSheet.Shapes("Picture 1")

myImage.Delete

End Sub

Confirm if the selected object is a picture

The code below will check if a specific object is a Picture.

Sub CheckIfSelectionIsPicture()

Dim thing As Object
Set thing = Selection

If TypeName(thing) = "Picture" Then
    MsgBox "Selection is a picture"
Else
    MsgBox "Selection is NOT a picture"
End If

End Sub

Linked pictures

Images can be linked to cells or named ranges.  This makes the image dynamic; when the contents of the cells change, so does the picture.

Sub MakeImageLinkedPicture()

Dim ws As Worksheet

Set ws = ActiveSheet

ws.Pictures("Picture 1").Formula = "=A1:D10"

End Sub

Image placement and locking options

Image behavior can be controlled using the placement option.

Sub ImagePlacementAndLockingOptions()

Dim myImage As Shape
Dim ws As Worksheet

Set ws = ActiveSheet
Set myImage = ws.Shapes("Picture 1")

'Image placement options
myImage.Placement = xlFreeFloating
'The other placement options are:
'xlMoveAndSize
'xlMove

'Locking images (prevent editing image when worksheet protected)
myImage.Locked = True
'The other placement options are:
'myImage.Locked = False

End Sub

Rotate images

The following code rotates the image by a specific amount

Sub RotateImageIncremental()

Dim myImage As Shape
Dim rotationValue As Integer

Set myImage = ActiveSheet.Shapes("Picture 1")
rotationValue = 45

'Rotate the image by the amount specified by the rotationValue
myImage.IncrementRotation (rotationValue)

End Sub

The following code rotates the image to a specific amount.

Sub RotateImageAbsolute()

Dim myImage As Shape
Dim rotationValue As Integer

Set myImage = ActiveSheet.Shapes("Picture 2")
rotationValue = 90

'Rotate the image to the amount specified by the rotationValue
myImage.rotation = rotationValue

End Sub

Set image position to the center of a cell

An image is positioned based on the top and left of that image. The following code will set the position so that it appears centered within a specific cell.

Sub CenterInCell()

Dim myImage As Shape
Dim cellLocation As Range

Set myImage = ActiveSheet.Shapes("Picture 1")
Set cellLocation = ActiveSheet.Range("B4")

myImage.Top = cellLocation.Top + (cellLocation.Height / 2) - (myImage.Height / 2)
myImage.Left = cellLocation.Left + (cellLocation.Width / 2) - (myImage.Width / 2)

End Sub

Flipping an image horizontally or vertically

Flip the image horizontally:

Sub FlipImageHorizontal()

Dim myImage As Shape
Set myImage = ActiveSheet.Shapes("Picture 1")

myImage.Flip msoFlipHorizontal

End Sub

Flip the image vertically:

Sub FlipImageVertical()

Dim myImage As Shape
Set myImage = ActiveSheet.Shapes("Picture 1")

myImage.Flip msoFlipVertical

End Sub

Resize an image

The code below locks the aspect ratio; therefore, resizing the width or height will maintain the image’s proportions.

Sub ResizeImageLockAspectRatio()

Dim myImage As Shape
Dim imageWidth As Double

Set myImage = ActiveSheet.Shapes("Picture 1")
imageWidth = 100

myImage.LockAspectRatio = msoTrue
myImage.Width = imageWidth

End Sub

When setting the aspect ratio to msoFalse, the height and width operate independently.

Sub ResizeImageHeightOrWidth()

Dim myImage As Shape
Dim imageWidth As Double
Dim imageHeight as Double

Set myImage = ActiveSheet.Shapes("Picture 1")
imageWidth = 100
imageHeight = 50

myImage.LockAspectRatio = msoFalse
myImage.Width = imageWidth
myImage.Height = imageHeight

End Sub

The following code positions an image and stretches it to perfectly cover a specified range.

Sub StretchImageToCoverCells()

Dim myImage As Shape
Dim ws As Worksheet
Dim rng As Range

Set ws = ActiveSheet
Set myImage = ws.Shapes("Picture 1")
Set rng = ws.Range("A2:D10")

myImage.LockAspectRatio = msoFalse

myImage.Left = rng.Left
myImage.Top = rng.Top
myImage.Width = rng.Width
myImage.Height = rng.Height

End Sub

Cropping

The code below crops an image based on the distance from the top, left, bottom or right.

Sub CropImage()

Dim myImage As Shape
Set myImage = ActiveSheet.Shapes("Picture1")

myImage.PictureFormat.CropLeft = 50
myImage.PictureFormat.CropTop = 50
myImage.PictureFormat.CropRight = 50
myImage.PictureFormat.CropBottom = 50

End Sub

Changing Z-Order

The image can be moved forward or backward within the stack of objects (known as the Z-Order).

Sub ChangeZOrderRelative()

Dim myImage As Shape

Set myImage = ActiveSheet.Shapes("Picture 1")

myImage.ZOrder msoBringForward

'Alternative send backward
'myImage.ZOrder msoSendBackward

End Sub

The Z-Order position cannot be set directly. First, send the image to the back, then move the image forward with a loop.  Continue looping until the image reaches the correct Z-Order Position.

Sub ChangeZOrderAbsolute()

Dim myImage As Shape
Dim imageWidth As Double
Dim imageZPosition As Integer

Set myImage = ActiveSheet.Shapes("Picture 1")
imageZPosition = 3

'Force z-order to zero then bring forward
myImage.ZOrder msoSendToBack

Do While myImage.zOrderPosition < imageZPosition

    myImage.ZOrder msoBringForward

Loop

End Sub

Set the background image

The background image appears behind the cells in the spreadsheet.

Sub SetImageBackground()

Dim ws As Worksheet
Dim imgPath As String

Set ws = ActiveSheet
imgPath = "C:UsersmarksDocumentsmyImage.png"

ws.SetBackgroundPicture fileName:=imgPath

'Remove the background image
'ws.SetBackgroundPicture fileName:="

End Sub

Save picture from Excel

If we have a picture in an Excel workbook, there is no straightforward way to save it to disk as a picture.  A common workaround is to set the picture as the background of a chart area, then export the chart as an image.

Sub SavePictureFromExcel()

Dim myPic As Shape
Dim tempChartObj As ChartObject
Dim savePath As String

Set myPic = ActiveSheet.Shapes("Picture 1")
Set tempChartObj = ActiveSheet.ChartObjects.Add(0, 0, myPic.Width, myPic.Height)
savePath = "C:UsersmarksDownloadsmySavedPic.jpg"

'Copy picture into chart, then export chart
myPic.Copy

tempChartObj.Chart.ChartArea.Select
tempChartObj.Chart.Paste
tempChartObj.Chart.Export savePath
tempChartObj.Delete

End Sub

Conclusion

In this post we have provided over 25 examples to demonstrate how to insert, delete, move and control pictures with VBA. Checkout the other posts on this site which use these techniques:

• 3 ways to change or insert images based cell values
• Creating custom Map Charts using shapes and VBA

Требуется макросом поместить изображение (картинку) на лист Excel?

Используйте функцию ВставитьКартинку, которая позволит вам вставить картинку в выбранную ячейку (или диапазон ячеек).

При вызове функции можно задать дополнительные дополнительные параметры, указав, следует ли подгонять картинку (или ячейку) по высоте и ширине.

В этом примере демонстрируются возможные варианты применения функции вставки картинок:

Sub ПримерВставкиИзображенийНаЛист()
 
    ПутьКФайлуСКартинками = "D:BMPAboutForm.jpg"    ' полный путь к файлу изображения

    ' вставка картинки в ячейку A5 (размеры картинки и ячейки не меняются)
    ВставитьКартинку Cells(5, 1), ПутьКФайлуСКартинками 
 
    ' вставка картинки в ячейку F5 (ячейка подгоняется по ШИРИНЕ под картинку)
    ВставитьКартинку Cells(5, 6), ПутьКФайлуСКартинками, True
 
    ' вставка картинки в ячейку E1 (ячейка подгоняется по ВЫСОТЕ под картинку)
    ВставитьКартинку [e1], ПутьКФайлуСКартинками, , True
 
    ' вставка картинки в ячейку F2 (ячейка принимает размеры картинки)
    ВставитьКартинку Range("F2"), ПутьКФайлуСКартинками, True, True
 
    ' =========================================
    ' вставка картинки в ячейку F5 (картинка подгоняется по ШИРИНЕ под ячейку)
    ВставитьКартинку Cells(5, 6), ПутьКФайлуСКартинками, True, , True
 
    ' вставка картинки в ячейку E1 (картинка подгоняется по ВЫСОТЕ под ячейку)
    ВставитьКартинку [e1], ПутьКФайлуСКартинками, , True, True
 
    ' вставка картинки в диапазон a2:e3 (картинка вписывается в диапазон)
    ВставитьКартинку [a2:e3], ПутьКФайлуСКартинками, True, True, True
 
End Sub

А вот и сама функция (скопируйте этот код в стандартный модуль, чтобы иметь возможность вставки картинок одной строкой кода из любого макроса):

Sub ВставитьКартинку(ByRef PicRange As Range, ByVal PicPath As String, _
                     Optional ByVal AdjustWidth As Boolean, _
                     Optional ByVal AdjustHeight As Boolean, _
                     Optional ByVal AdjustPicture As Boolean = False)
    ' ==========  функция получает в качестве параметров:  ====================
    ' PicRange - прямоугольный диапазон ячеек, поверх которого будет расположено изображение
    ' PicPath - полный путь к файлу картинки (файл в формате JPG, BMP, PNG, и т.д.)
    ' AdjustWidth - если TRUE, то включен режим подбора ширины (подгонка по высоте)
    ' AdjustHeight - если TRUE, то включен режим подбора высоты (подгонка по ширине)
    ' AdjustPicture - если TRUE, то подгоняются размеры картинки под ячейку,
    '                 если FALSE (по умолчанию), то изменяются размеры ячейки

    On Error Resume Next: Application.ScreenUpdating = False
    ' вставка изображения на лист
    Dim ph As Picture: Set ph = PicRange.Parent.Pictures.Insert(PicPath)
    ' совмещаем левый верхний угол ячейки и картинки
    ph.Top = PicRange.Top: ph.Left = PicRange.Left
 
    K_picture = ph.Width / ph.Height    ' вычисляем соотношение размеров сторон картинки
    K_PicRange = PicRange.Width / PicRange.Height    ' вычисляем соотношение размеров сторон диапазона ячеек

    If AdjustPicture Then    ' ПОДГОНЯЕМ РАЗМЕРЫ ИЗОБРАЖЕНИЯ под ячейку (оптимальный вариант)

        ' если AdjustWidth=TRUE, то высоту не трогаем - изменяем ширину
        If AdjustWidth Then ph.Width = PicRange.Width: ph.Height = ph.Width / K_picture
 
        ' если AdjustHeight=TRUE, то ширину не трогаем - изменяем высоту
        If AdjustHeight Then ph.Height = PicRange.Height: ph.Width = ph.Height * K_picture
 
        ' AdjustWidth=TRUE и AdjustHeight=TRUE: вписываем картинку в ячейку (без соблюдения пропорций)
        If AdjustWidth And AdjustHeight Then ph.Width = PicRange.Width: ph.Height = PicRange.Height
 
 
    Else    ' ИЗМЕНЯЕМ РАЗМЕРЫ ЯЧЕЙКИ под размеры изображения (нежелательно при вставке НЕСКОЛЬКИХ картинок...)

        If AdjustWidth Then    ' если AdjustWidth=TRUE, то высоту не трогаем - изменяем ширину
            PicRange.Cells(1).ColumnWidth = PicRange.Cells(1).ColumnWidth * ph.Width / PicRange.Cells(1).Width
            While Abs(PicRange.Cells(1).Width - ph.Width) > 0.1    ' точный подбор ширины ячейки
                PicRange.Cells(1).ColumnWidth = PicRange.Cells(1).ColumnWidth - 0.2 * (PicRange.Cells(1).Width - ph.Width)
            Wend
        End If
 
        If AdjustHeight Then    ' если AdjustHeight=TRUE, то ширину не трогаем - изменяем высоту
            PicRange.Cells(1).RowHeight = PicRange.Cells(1).RowHeight * ph.Height / PicRange.Cells(1).Height
            While Abs(PicRange.Cells(1).Height - ph.Height) > 0.1    ' точный подбор высоты ячейки
                PicRange.Cells(1).RowHeight = PicRange.Cells(1).RowHeight - 0.2 * (PicRange.Cells(1).Height - ph.Height)
            Wend
        End If
 
    End If
End Sub