Вставить картинку в лист - по списку или выбору из ячейки
Сама по себе задача вставки картинки на листе не сложная и ответ лежит на поверхности: это доступно прямо из меню: Вставка
Кодом VBA вставить тоже не сложно, даже макрорекордер записывает это действие:
Sub InsertPicture() ActiveSheet.Pictures.Insert("G:\Документы\Изображения\Excel_vba_ru.png"). _ Select End Sub |
Но что делать, если вставить надо картинку из заранее известной папки, но с изменяющимся именем? А если при этом еще надо не просто вставить - а подогнать размер картинки под размер ячейки? Например, в ячейке
'--------------------------------------------------------------------------------------- ' 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(
Значит теперь попробуем сделать так, чтобы при каждом изменении в
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 |
Теперь переходим на лист, где в
Если картинки расположены не в
заменить такими
sPicsPath = ThisWorkbook.Path & "\"
тогда папка с книгой будет определяться автоматически.
Но я понимаю, что куда правильнее в ячейке
Вставить картинку в ячейку (366,9 KiB, 2 483 скачиваний)
И еще часто встречающаяся задача по вставке картинок - это вставка картинок массово. Т.е. вставить картинки на основании значений, записанных в столбце. В данном случае это столбец В. А вставлять картинки будем в столбец С, подгоняя размеры картинок под размер каждой ячейки и проверяя, не вставляли ли мы эту картинку туда ранее
Впрочем, основная часть кода была приведена выше - здесь мы лишь добавим цикл по ячейкам. Так же в этом коде мы используем диалог выбора папки, в котором просматривать картинки:
'--------------------------------------------------------------------------------------- ' 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 483 скачиваний)
Обратная задача - сохранение картинок из листа - уже разбиралась мной в этой статье: Как сохранить картинки из листа Excel в картинки JPG
Так же см.:
Как сохранить картинки из листа Excel в картинки JPG
При вставке из VBA картинки на лист ошибка "Метод paste из класса worksheet завершен неверно"
Как скопировать картинку из примечания?
Копирование картинки из примечания
Статья помогла? Поделись ссылкой с друзьями!
