Хитрости »

6 Февраль 2020 Дмитрий 29417 просмотров

Основные понятия (27)
Сводные таблицы и анализ данных (10)
Графики и диаграммы (5)
Работа с VB проектом (12)
Power BI и Power Query (23)

Условное форматирование (5)
Списки и диапазоны (5)
Макросы(VBA процедуры) (68)
Разное (43)
Баги и глюки Excel (5)

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

Сама по себе задача вставки картинки на листе не сложная и ответ лежит на поверхности: это доступно прямо из меню: Вставка(Insert) -группа Иллюстрации(Illustrations) -Рисунок(Picture):
Вставка Рисунка в Excel
Кодом 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

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 983 скачиваний)

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

'---------------------------------------------------------------------------------------
' 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

'--------------------------------------------------------------------------------------- ' 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 983 скачиваний)

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

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

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

Видеоуроки

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

Обсуждение: 2 комментария

Андрей:

27.11.2023 в 12:50

Как переписать код, чтобы картинка вписывалась в ячейку без соблюдения пропорций

Ответить

Дмитрий:

27.11.2023 в 15:24

Вместо этих строк:

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

Вставить такие:

Set oShp = ActiveSheet.Shapes.AddPicture(sPFName, False, True, .Left + 1, .Top + 1, -1, -1)
oShp.LockAspectRatio = False
oShp.Height = .Height
oShp.Width = .Width

Ответить

Поделитесь своим мнением

Комментарии, не имеющие отношения к комментируемой статье, могут быть удалены без уведомления и объяснения причин. Если есть вопрос по личной проблеме - добро пожаловать на Форум

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

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

Спасибо за сообщение