Макрос для вставки картинки в ячейку excel

Требуется макросом поместить изображение (картинку) на лист 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

Хитрости »

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


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

Сама по себе задача вставки картинки на листе не сложная и ответ лежит на поверхности: это доступно прямо из меню: Вставка(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) —InsertModule) и вставить в него приведенный выше код. Чтобы картинка вставилась в ячейку, надо записать имя картинки в ячейку 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 393 скачиваний)


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

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

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

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


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

  Плейлист   Видеоуроки


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



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

Уже несколько лет в Google Sheets существует функция IMAGE, позволяющая вставлять в ячейки листа картинки по ссылке из интернета. Что, впрочем, вполне естественно, поскольку Google-таблицы изначально заточены под работу онлайн — им сам бог велел такую возможность использовать.

У Excel же ничего подобного долго не было. И вот, наконец, осенью 2022 года Microsoft начала среди добровольцев-тестировщиков из программы Office Insider обкатку своего аналога —  новой функции ИЗОБРАЖЕНИЕ (IMAGE), также позволяющей вставлять по веб-ссылке картинки из интернета прямо в ячейки листа Microsoft Excel. В начале 2023 года эту функцию уже стали потихонечку разливать с обновлениями подписчикам Office 365 и недавно она, наконец, добралась и до меня. А значит я могу вам о ней рассказать на нескольких практических примерах.

Если же последней версии Office у вас пока (или уже) не предвидится, то не расстраивайтесь — в конце этой статьи я покажу как при помощи короткого макроса можно сделать упрощённый аналог этой функции уже сегодня.

Синтаксис функции ИЗОБРАЖЕНИЕ (IMAGE)

Тут всё предельно просто:

=ИЗОБРАЖЕНИЕ(источник; [замещающий_текст]; [изменение_размера]; [высота]; [ширина])

Первым и единственным обязательным аргументом новой функции должна быть текстовая ссылка на файл изображения из интернета. Причем это должна быть именно веб, а не локальная ссылка на файл на жестком или сетевом диске. Если доступа в интернет сейчас нет, то вместо картинки будет ошибка #СОЕДИНЕНИЕ! (если нет интернета) или #ЗАБЛОКИР! (если ваши настройки безопасности не дают загрузить картинку). Если вы хотите подстраховаться на такой случай, то вторым аргументом как раз можно ввести замещающий текст, который будет отображен вместо отсутствующей картинки.

Третий аргумент отвечает за размеры и пропорции изображения и может принимать значения:

  • 0 — вписать изображение в ячейку с сохранением пропорций
  • 1 — заполнить всю площадь ячейки не сохраняя пропорции картинки
  • 2 — сохранить исходный размер изображения (тут оно запросто может вылезти за пределы ячейки)
  • 3 — задать высоту и ширину изображения принудительно (тогда их надо обязательно прописать в четвертом и пятом аргументе функции)

Большим преимуществом новой функции является то, что картинка будет не просто вставлена на лист, а именно вписана в конкретную ячейку, т.е. будет вместе с ней двигаться, сжиматься и растягиваться. Это принципиально отличается от классической вставки картинок командой Вставка — Рисунки (Insert — Pictures), когда изображение и лист находились, по сути, в разных слоях и вы могли запросто случайно сдвинуть или даже удалить картинку после вставки. Здесь же всё чётко.

Также если щёлкнуть по вставленному функцией изображению правой кнопкой мыши и выбрать команду Показать сведения об изображении (Show image properties), то во всплывающем окне можно будет увидеть картинку в оригинальном разрешении.

Теперь давайте рассмотрим несколько вкусных примеров использования новой функции ИЗОБРАЖЕНИЕ на практике.

Пример 1. Создание штрих-кодов и QR-кодов

Этикетки для маркировки товаров, ценники, бланки, наклейки — всё это требует формирования штрих-кодов различного типа. Теперь для этого можно не использовать специальные программы, а реализовать всё в Excel.

Идём на сайт австрийской компании TEC-IT, где можно легко создать штрих-код любого стандарта с заданным содержимым:

Генератор штрих-кодов

Ссылка, по которой формируется изображение штрих-кода висит на кнопке Download и выглядит так:

_ttps://barcode.tec-it.com/en/Тип_штрихкода?data=Наше_содержимое_кода

Например, для распространенного типа Code-128, который кодирует строку «ABC-abc-1234» ссылка будет выглядеть как:

_ttps://barcode.tec-it.com/en/Code128?data=ABC-abc-1234

Так что просто подклеиваем справа от последнего знака «равно» наши артикулы, заворачиваем всё в функцию ИЗОБРАЖЕНИЕ и получаем автоматизированное создание штрих-кодов для любого количества товаров:

Штрих-коды

Красота.

Если нужен не линейный, а квадратный QR-код, то можно использовать другой бесплатный сайт — QR Code Generator:

Генератор QR-кодов

Здесь ссылка для формирования QR-кода выглядит следующим образом:

ttps://api.qrserver.com/v1/create-qr-code/?data=Наши_данные&size=100×100

Опять же, подставляем туда адреса ячеек с исходными данными и получаем возможность массово клепать QR-коды в любом количестве:

QR-код в Excel с функцией ИЗОБРАЖЕНИЕ

Пример 2. Логотипы компаний

Ещё одна любопытная возможность — это автоматизированная загрузка логотипов известных компаний с помощью веб-сервиса https://logo.clearbit.com. Идея та же — подклеиваем адрес сайта нужной нам компании в конец ссылки — и получаем от сервиса изображение логотипа заданной компании, которое выводит на лист наша функция ИЗОБРАЖЕНИЕ:

Логотипы компаний

Можно использовать в дашбордах по анализу рынка, для визуализации инвестиционного портфеля, в прайс-листах и т.д. — у кого на сколько фантазии хватит.

Пример 3. Нестандартные диаграммы

На сайте QuickChart.io можно в режиме онлайн-конструктора создавать разнообразные диаграммы по вашим данным и использовать их затем в ваших проектах. Нюанс в том, что помимо стандартных диаграмм (которые Excel и сам неплохо умеет строить), здесь есть несколько весьма симпатичных нестандартных, например, спидометры и прогресс-бары, диаграммы Санкей для визуализации связей и т.д.

Для получения, например, круговой диаграммы-шкалы прогресса, нам потребуется сформировать вот такую веб-ссылку:

ttps://quickchart.io/chart?c={type:’radialGauge’,data:{datasets:[{data:[Значение_параметра],backgroundColor:’green’}]}}

И визуализировать её затем с помощью нашей новой функции ИЗОБРАЖЕНИЕ (IMAGE):

Диаграмма

Или можно, например, сформировать и вывести изображение вот такого нарядного спидометра со стрелкой:

Спидометр

Здесь ссылка чуть похитрее, т.к. в неё уже зашиты размеры трёх диапазонов шкалы и их цвета, а также положение стрелки:

ttps://quickchart.io/chart?c={ type: ‘gauge’, data: { datasets: [ { data: [10, 40, 60], value: Позиция_стрелки, backgroundColor: [‘green’, ‘gold’, ‘lightcoral’] } ] } } 

Названия цветов для заливки сегментов диаграммы можно взять из справочника.

Пример 4. Скриншоты сайтов

Если вы работаете с интернет-ресурсами или в области SEO-SMM, то вам пригодится возможность быстро формировать скриншоты заданных веб-страниц и вставлять их на лист Excel в виде изображений. Это можно сделать с помощью веб-сервиса https://mini.s-shot.ru, добавив к его адресу ссылку на интересующую страницу.

Подставляем её в нашу функцию ИЗОБРАЖЕНИЕ и получаем:

Скриншоты веб-страниц

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

Пример 5. Географические карты

Опять же, вставлять на лист интерактивные географические карты Excel уже давно умеет (через Вставка — Карты Bing, например), но можно это сделать и с помощью новой функции ИЗОБРАЖЕНИЕ, если найти веб-сервис, который по заданным координатам или названию населенного пункта будет формировать для нас скриншот карты в нужном месте. Обычно такие сервисы платные и используют API — специальный механизм запросов для общения с ними. 

Например, на одном из таких сайтов Geoapify.com ссылка для получения нужного фрагмента карты случае формируется из:

  • долготы (longtitude)
  • широты (latitude)
  • коэффициента масштаба (zoom)
  • ключа API — длинного буквенно-цифрового кода, который вы получаете в личном кабинете в качестве вашего личного идентификатора:

Изображение карты по API

Обратите внимание, что в качестве разделителя между целой и дробной частью должна быть использована точка, поэтому дополнительно придётся использовать функцию ПОДСТАВИТЬ (SUBSTITUTE), чтобы её подменить.

Аналог функции IMAGE на VBA

Если приведенные выше примеры вас заинтриговали, но последней версии Excel у вас пока нет, то можно относительно легко склепать на коленке упрощенный аналог этой функции на Visual Basic. Только вставлять картинки он будет не по ссылке из интернета, а по пути к файлу с жесткого диска вашего ПК (что в некоторых случаях может быть даже предпочтительнее — интернет у нас не везде бывает).

Откройте редактор макросов сочетанием клавиш Alt+F11 или кнопкой Visual Basic на вкладке Разработчик (Developer). Вставьте новый пустой модуль командой меню Insert — Module и скопируйте туда текст следующего макроса:

Sub InsertPictures()
    Dim pic As Shape
    Dim cell as Range, imageCell as Range
    
    'проходим по выделенным непустым ячейкам
    For Each cell In Selection
        If Not IsEmpty(cell) Then
            Set imageCell = cell.Offset(0, 1)       'определяем ячейку справа для вставки картинки
        
            'вставляем картинку
            Set pic = ActiveSheet.Shapes.AddPicture(cell.Value, False, True, imageCell.Left, imageCell.Top, -1, -1)
                
            pic.LockAspectRatio = True              'фиксируем соотношение сторон
            pic.Height = imageCell.Height           'подгоняем по высоте под ячейку
        End If
    Next cell

End Sub

Теперь останется ввести в ячейки листа пути к файлам картинок, а затем выделить эти ячейки и запустить наш макрос командой Разработчик — Макросы (Developer — Macros) или сочетанием клавиш Alt+F8. Макрос пробежит по всем выделенным ячейкам и вставит в каждую картинку из указанного файла, вписав её в по размерам в каждую ячейку.

Вставка картинок макросом

Картинки, правда, будут не внутри ячеек, как в случае с функцией IMAGE, а — как обычно — в отдельном слое, так что изменение высоты строк не приведёт к автоматической подгонке размеров изображений.

Если нужно будет подгонять размер картинок не по высоте, а по ширине ячеек, то замените в коде свойство Height на Width.

Ссылки по теме

  • Выпадающий список с показом изображений
  • Картинка в примечании к ячейке
  • Создание печатной подложки в Excel

Вставка существующего рисунка (фигуры, другого объекта) в ячейку Excel с помощью кода VBA. Подгон ячейки под размеры рисунка и фигуры под размеры ячейки.

Подгон ячейки под размеры рисунка

Вставка рисунка в ячейку из кода VBA Excel с подгоном размеров ячейки под размеры фигуры (картинки).

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

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

Код VBA Excel для вставки рисунка в ячейку с подгоном размеров ячейки под размеры фигуры (картинки):

Sub Primer1()

    With Лист20

        .Shapes(«Рисунок 1»).Placement = xlMove

        ‘изменяем ширину ячейки (столбца) в символах до 1/5 ширины рисунка в пунктах

        .Range(«B3»).ColumnWidth = .Shapes(«Рисунок 1»).Width / 5

        ‘изменяем высоту ячейки (строки) до высоты рисунка + 10 точек для отступов

        .Range(«B3»).RowHeight = .Shapes(«Рисунок 1»).Height + 10

        ‘задаем отступ рисунка от левого края ячейки на 5 пунктов

        .Shapes(«Рисунок 1»).Left = .Range(«B3»).Left + 5

        ‘задаем отступ рисунка от верхнего края ячейки на 5 пунктов

        .Shapes(«Рисунок 1»).Top = .Range(«B3»).Top + 5

    End With

End Sub

Свойству Placement объекта Shapes присваиваем значение константы xlMove, которое задает возможность перемещать рисунок вместе с ячейками, но не изменять его размеры при изменении размеров ячеек. Доступные константы из коллекции XlPlacement перечислены ниже.

Было:

Стало:

Подгон фигуры под размеры ячейки

Вставка рисунка в ячейку из кода VBA Excel с подгоном размеров картинки (фигуры) под размеры ячейки.

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

Код VBA Excel для вставки рисунков в ячейки с подгоном размеров картинок (фигур) под размеры ячеек:

1

2

3

4

5

6

7

8

9

10

11

12

13

14

15

16

17

18

Sub Primer2()

Dim i As Byte, n As Single

    For i = 1 To 5

        With Лист19

            ‘определяем, во сколько раз будет изменена высота рисунка

            n = .Shapes(i).Height / .Cells(i, 1).Height

            .Shapes(i).Placement = xlMove

            ‘изменяем высоту рисунка до высоты ячейки

            .Shapes(i).Height = .Cells(i, 1).Height

            ‘изменяем ширину рисунка пропорционально изменению его высоты

            .Shapes(i).Width = .Shapes(i).Width / n

            ‘выравниваем рисунок по левому краю ячейки

            .Shapes(i).Left = .Cells(i, 1).Left

            ‘выравниваем рисунок по верхнему краю ячейки

            .Shapes(i).Top = .Cells(i, 1).Top

        End With

    Next

End Sub

Было:

Стало:

Константы из коллекции XlPlacement

Константы из коллекции XlPlacement определяют реакцию рисунка, фигуры или другого объекта из группы «Иллюстрации» на перемещение и изменение размеров ячеек, над которыми рисунок расположен.

Описание констант из коллекции XlPlacement:

Константа Значение Описание
xlMoveAndSize 1 Объект перемещается и изменяет размеры вместе с ячейками
xlMove 2 Объект перемещается вместе с ячейками, но не изменяет размеры
xlFreeFloating 3 Объект не перемещается и не изменяет размеры вместе с ячейками

Вставка картинки согласно параметрам ячейки

Gopronotmore

Дата: Понедельник, 20.04.2020, 19:28 |
Сообщение № 1

Группа: Проверенные

Ранг: Форумчанин

Сообщений: 183


Репутация:

1

±

Замечаний:
0% ±


Excel 2007

Друзья, добрый вечер.

Я плохо разбираюсь в VBA, но нужно сделать макрос вставки картинки в ячейку.

1 Вопрос. При отмене вставки выпадает ошибка, как ее убрать.
2 Вопрос. Как прописать Width:= xxx Height:= xxx согласно размерам ячейки.

Файл прилагаю

Заранее спасибо

К сообщению приложен файл:

0381247.xlsm
(20.1 Kb)

 

Ответить

_Boroda_

Дата: Понедельник, 20.04.2020, 20:02 |
Сообщение № 2

Группа: Модераторы

Ранг: Местный житель

Сообщений: 16618


Репутация:

6465

±

Замечаний:
0% ±


2003; 2007; 2010; 2013 RUS

Так нужно?

[vba]

Код

Sub InsertPicUsingShapeAddPictureFunction()
    Dim profile     As String
    On Error Resume Next
    Dim fd          As FileDialog
    Set fd = Application.FileDialog(msoFileDialogFilePicker)
    With fd
        .Filters.Clear
        .Filters.Add «Picture Files», «*.bmp;*.jpg;*.gif;*.png»
        .ButtonName = «Select»
        .AllowMultiSelect = False
        .Title = «Choose Photo»
        .InitialView = msoFileDialogViewDetails
        .Show
    End With
    With ActiveSheet.Range(«D2»)
        ActiveSheet.Shapes.AddPicture Filename:=fd.SelectedItems(1), _
            LinkToFile:=msoFalse, _
            SaveWithDocument:=msoCTrue, _
            Left:=.Left + 2, _
            Top:=.Top + 2, _
            Width:=.Width, _
            Height:=.Height
    End With
End Sub

[/vba]


Скажи мне, кудесник, любимец ба’гов…
Платная помощь:
Boroda_Excel@mail.ru
Яндекс-деньги: 41001632713405 | Webmoney: R289877159277; Z102172301748; E177867141995

 

Ответить

Gopronotmore

Дата: Понедельник, 20.04.2020, 20:11 |
Сообщение № 3

Группа: Проверенные

Ранг: Форумчанин

Сообщений: 183


Репутация:

1

±

Замечаний:
0% ±


Excel 2007

_Boroda_, да. Спасибо Вам большое

 

Ответить

_Boroda_

Дата: Понедельник, 20.04.2020, 20:22 |
Сообщение № 4

Группа: Модераторы

Ранг: Местный житель

Сообщений: 16618


Репутация:

6465

±

Замечаний:
0% ±


2003; 2007; 2010; 2013 RUS

Только обратите внимание, что если несколько раз вставлять картинки, то предыдущая не удаляется и в итоге получится, что у Вас в ячейке будет куча картинок, наложенных друг на дружку
Вот так попробуйте
[vba]

Код

Sub InsertPicUsingShapeAddPictureFunction()
    Dim profile     As String
    On Error Resume Next
    Dim fd          As FileDialog
    Set fd = Application.FileDialog(msoFileDialogFilePicker)
    With fd
        .Filters.Clear
        .Filters.Add «Picture Files», «*.bmp;*.jpg;*.gif;*.png»
        .ButtonName = «Select»
        .AllowMultiSelect = False
        .Title = «Choose Photo»
        .InitialView = msoFileDialogViewDetails
        .Show
    End With
    With ActiveSheet.Range(«D2»)
        For Each as_ In ActiveSheet.Shapes
            If as_.Left = .Left + 2 Then
                as_.Delete
                Exit For
            End If
        Next as_
        ActiveSheet.Shapes.AddPicture Filename:=fd.SelectedItems(1), _
            LinkToFile:=msoFalse, _
            SaveWithDocument:=msoCTrue, _
            Left:=.Left + 2, _
            Top:=.Top + 2, _
            Width:=.Width, _
            Height:=.Height
    End With
End Sub

[/vba]


Скажи мне, кудесник, любимец ба’гов…
Платная помощь:
Boroda_Excel@mail.ru
Яндекс-деньги: 41001632713405 | Webmoney: R289877159277; Z102172301748; E177867141995

 

Ответить

Gopronotmore

Дата: Понедельник, 20.04.2020, 21:38 |
Сообщение № 5

Группа: Проверенные

Ранг: Форумчанин

Сообщений: 183


Репутация:

1

±

Замечаний:
0% ±


Excel 2007

_Boroda_, это вообще шикарно!

Спасибо большое за крутой лайф хак

 

Ответить

Gopronotmore

Дата: Вторник, 21.04.2020, 16:36 |
Сообщение № 6

Группа: Проверенные

Ранг: Форумчанин

Сообщений: 183


Репутация:

1

±

Замечаний:
0% ±


Excel 2007

_Boroda_, Подскажите пожалуйста, если надо вставить фото в Ячеку D2 и в ячеку E2, F2, G2. Что бы выбирал ячейку и потом нажимал вставить фото и фотка вставлялась в выбранную ячейку. Как это реализовать ?

К сообщению приложен файл:

primer.xlsm
(21.1 Kb)

Сообщение отредактировал GopronotmoreВторник, 21.04.2020, 16:38

 

Ответить

_Boroda_

Дата: Вторник, 21.04.2020, 16:53 |
Сообщение № 7

Группа: Модераторы

Ранг: Местный житель

Сообщений: 16618


Репутация:

6465

±

Замечаний:
0% ±


2003; 2007; 2010; 2013 RUS

Так нужно?


Скажи мне, кудесник, любимец ба’гов…
Платная помощь:
Boroda_Excel@mail.ru
Яндекс-деньги: 41001632713405 | Webmoney: R289877159277; Z102172301748; E177867141995

 

Ответить

Gopronotmore

Дата: Вторник, 21.04.2020, 19:07 |
Сообщение № 8

Группа: Проверенные

Ранг: Форумчанин

Сообщений: 183


Репутация:

1

±

Замечаний:
0% ±


Excel 2007

_Boroda_, да спасибо болошьшое. А у меня вопрос. Мы прописываем строгий диапазон ячеек. А можно как-то от него отойти ? Или всегда нужно будет его прописывать ?

 

Ответить

_Boroda_

Дата: Вторник, 21.04.2020, 19:15 |
Сообщение № 9

Группа: Модераторы

Ранг: Местный житель

Сообщений: 16618


Репутация:

6465

±

Замечаний:
0% ±


2003; 2007; 2010; 2013 RUS

Слушайте, Вы сами написали

надо вставить фото в Ячеку D2 и в ячеку E2, F2, G2

А теперь отойти нужно :D :D :D
Держите. Кстати, теперь можно выделять несколько ячеек, вставлять картинку будет в левую верхнюю
И да, в предыдущем файле (если будете им пользоваться) раскомментируйте строку
[vba][/vba]


Скажи мне, кудесник, любимец ба’гов…
Платная помощь:
Boroda_Excel@mail.ru
Яндекс-деньги: 41001632713405 | Webmoney: R289877159277; Z102172301748; E177867141995

 

Ответить

Gopronotmore

Дата: Вторник, 21.04.2020, 19:33 |
Сообщение № 10

Группа: Проверенные

Ранг: Форумчанин

Сообщений: 183


Репутация:

1

±

Замечаний:
0% ±


Excel 2007

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

 

Ответить

Понравилась статья? Поделить с друзьями:
  • Макрос для всех страниц в excel
  • Макрос для всех книг excel при открытии
  • Макрос для всех книг excel в папке
  • Макрос для всех книг excel 2010
  • Макрос для всех книг excel 2007