Вставка изображения в ячейку с помощью кода VBA Excel, программная вставка картинки в примечание (заметку) с выбором файла через диалоговое окно.
Автоматизация вставки изображений
Ручная вставка изображений в ячейки Excel отнимает время, особенно когда нужно оформить каталог товаров, карточки сотрудников или фотоотчёт. С помощью VBA этот процесс можно автоматизировать практически до пары кликов.
В этой статье рассмотрены 2 способа размещения картинки в ячейке Excel с помощью VBA:
- Вставка изображения непосредственно в активную ячейку с автоматической подгонкой пропорций.
- Вставка картинки в примечание (заметку) к активной ячейке.
Оба скрипта открывают стандартное диалоговое окно выбора файла и работают в Excel 2010–2026 года. Окно выбора файла позволяет не менять адрес изображения при каждом запуске кода.
Вставка изображения в ячейку
Вставка картинки непосредственно в активную ячейку с автоматической подгонкой размера:
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 |
Sub ВставитьКартинкуВАктивнуюЯчейку() Dim imgPath As String Dim targetCell As Range Dim shp As Shape Dim cellRatio As Double, imgRatio As Double Dim fd As FileDialog Dim i As Long ' Выбор файла Set fd = Application.FileDialog(msoFileDialogFilePicker) With fd .Title = "Выберите изображение" .Filters.Clear .Filters.Add "Изображения", "*.jpg; *.jpeg; *.png; *.bmp; *.gif" .AllowMultiSelect = False If .Show = -1 Then imgPath = .SelectedItems(1) Else Exit Sub End If End With Set fd = Nothing Set targetCell = ActiveCell Application.ScreenUpdating = False On Error GoTo ErrorHandler ' Удаляем старые картинки в этой ячейке For i = ActiveSheet.Shapes.Count To 1 Step -1 Set shp = ActiveSheet.Shapes(i) If Not shp.TopLeftCell Is Nothing Then If shp.TopLeftCell.Address = targetCell.Address Then shp.Delete End If Next i ' Вставка картинки Set shp = ActiveSheet.Shapes.AddPicture( _ FileName:=imgPath, _ LinkToFile:=msoFalse, _ SaveWithDocument:=msoTrue, _ Left:=targetCell.Left, Top:=targetCell.Top, _ Width:=-1, Height:=-1) ' Сохранение пропорций cellRatio = targetCell.Width / targetCell.Height imgRatio = shp.Width / shp.Height If imgRatio > cellRatio Then shp.Width = targetCell.Width shp.Height = targetCell.Width / imgRatio Else shp.Height = targetCell.Height shp.Width = targetCell.Height * imgRatio End If ' Центрирование shp.Left = targetCell.Left + (targetCell.Width - shp.Width) / 2 shp.Top = targetCell.Top + (targetCell.Height - shp.Height) / 2 Application.ScreenUpdating = True MsgBox "Картинка вставлена в " & targetCell.Address, vbInformation Exit Sub ErrorHandler: Application.ScreenUpdating = True MsgBox "Ошибка: " & Err.Description, vbCritical End Sub |
Результат работы кода:
Если вам необходима на листе Excel группа одинаковых изображений, полностью заполняющих ячейки, как на скриншоте, загружайте картинки одинакового размера.
Вставка картинки в примечание
Вставка изображения в примечание (заметку) к активной ячейке:
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 |
Sub ВставитьКартинкуВПримечаниеАктивнойЯчейки() Dim imgPath As String Dim targetCell As Range Dim cmt As Comment Dim fd As FileDialog Set fd = Application.FileDialog(msoFileDialogFilePicker) With fd .Title = "Выберите изображение для комментария" .Filters.Clear .Filters.Add "Изображения", "*.jpg; *.jpeg; *.png; *.bmp; *.gif" .AllowMultiSelect = False If .Show = -1 Then imgPath = .SelectedItems(1) Else Exit Sub End If End With Set fd = Nothing Set targetCell = ActiveCell On Error GoTo ErrorHandler Application.ScreenUpdating = False If Not targetCell.Comment Is Nothing Then targetCell.Comment.Delete Set cmt = targetCell.AddComment("") cmt.Shape.Fill.UserPicture imgPath cmt.Shape.Line.Visible = msoFalse cmt.Text "" ' Отношение ширины к высоте примечания должны соответствовать отношению ширины ' к высоте изображения, иначе пропорции картинки не будут сохранены cmt.Shape.Width = 200 cmt.Shape.Height = 250 Application.ScreenUpdating = True MsgBox "Картинка добавлена в примечание ячейки " & targetCell.Address, vbInformation Exit Sub ErrorHandler: Application.ScreenUpdating = True MsgBox "Ошибка: " & Err.Description, vbCritical End Sub |
Результат работы кода:
Чтобы картинка в примечании отображалась без искажений, как на скриншоте, размеры окна комментария должны сохранять те же пропорции, что и у исходного изображения.
В Excel 365/2021+ обычные комментарии (примечания) переименованы в «Заметки». Метод AddComment создаёт именно их, что идеально для вывода изображений. Новые «обсуждаемые» комментарии (AddCommentThreaded) не поддерживают фоновые изображения.
Совет: чтобы макросы для вставки изображения в ячейку Excel были доступны во всех книгах, сохраните их в личную книгу макросов (Personal.xlsb).
Автоматизация вставки изображений через VBA экономит часы рутинной работы. Предложенные макросы готовы к использованию, безопасны и адаптированы под современные версии Excel.