mail mail
Нужен макрос для Excel?
Сделайте заказ прямо сейчас!
Ищете готовое решение?
Выбирайте и покупайте!
У вас есть интернет-магазин?
Настроим парсер под любой сайт!

Вставка картинок и изображений в ячейки листа Excel

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

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

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

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

Кроме того, надстройка для вставки изображений в Excel умеет загружать картинки из интернета (по ссылкам в таблице Excel)

Бесплатно скачать надстройку вставки картинок в Excel

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

Sub ПримерВставкиИзображенийНаЛист()
 
    ПутьКФайлуСКартинками = "D:\BMP\AboutForm.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

Комментарии

Настройки просмотра комментариев

Выберите нужный метод показа комментариев и нажмите "Сохранить установки".

Set Pic = Sheets("Price ").Shapes.AddPicture(FileName, LinkToFile, SaveWithDocument , Left, Top, Width, Height)

FileName — строка, задающая имя файла, на основе которого создается рисунок
LinkToFile — допустимые значения: True (рисунок связан с файлом, на основе которого создан) и False (в противном случае)
SaveWithDocument — допустимые значения: True(сохраняется рисунок с рабочей книгой) и False (в рабочей книге сохраняется связь с рисунком, а не сам рисунок)
Left, Top — координаты левого верхнего угла объекта
Width, Height — ширина и высота объекта

Сергей, если почитаете комменты к статье, — найдете ответ на этот вопрос.

Здравствуйте! Все работает и вставляет... НО!!! После изменения пути расположения картинок, и открытии вновь файла, на месте картинки пишется следующий текст: " Не удается отобразить связанный рисунок. Возможно, этот файл был перемещен, переименован или удален. Убедитесь, что ссылка указывает на правильный файл и верное размещение."
Пользуюсь Excel 2016. Почему он вставляет картинки как ссылки, и как это можно исправить?
Заранее спасибо!

ну вставка происходит не в ячейку а поверх ее

как с помощью макроса выбора изображения, вставить картинки, спасибо
Sub InsertPicture()
Dim FD As FileDialog
Dim iFileName As String
Set FD = Application.FileDialog(msoFileDialogFilePicker)
With FD
.Filters.Clear
.Filters.Add "Âñå ðèñóíêè", "*.*"
.Filters.Add "JPG", "*.jpg"
.Filters.Add "Ðèñóíêè", "*.bmp"
.Filters.Add "PNG", "*.png"
.Filters.Add "tif", "*.tif"
.FilterIndex = 2
.AllowMultiSelect = False
.InitialFileName = ThisWorkbook.Path
.Title = "Äîáàâëåíèå ðèñóíêà"
.ButtonName = "Âñòàâèòü"
If .Show = False Then
'MsgBox "Âû íå óêàçàëè íóæíûé ôàéë!", 48, "Îøèáêà"
Exit Sub
Else
iFileName = Right(.SelectedItems(1), Len(.SelectedItems(1)) - InStrRev(.SelectedItems(1), "\"))
If Right(UCase(iFileName), 4) = ".XLS" Then iFileName = Left(iFileName, Len(iFileName) - 4)
End If
End With
Set FD = Nothing
ActiveSheet.Pictures.Insert(iFileName).Select - ВОТ тут я завершились мои познания в VBA ?????
End Sub

Возможно, столбец с именами файлов неверно задан
Если сами не разберетесь, - звоните в скайп, помогу

Надстройка у меня есть. Все так и делаю, обрабатывает все изображения а потом пишет что сохраненных ноль.(

Скачиваете и запускаете эту надстройку
http://excelvba.ru/programmes/PastePictures
Потом нажимаете в меню: Изображения - Сохранить картинки с листа в файлы

Добрый день. Простите, но у меня не получается выгрузить фотки из файла в папку. программа видит изображения , но не сохраняет их.
Видимо я что то не так делаю. Помогите пожалуйста. Напишите последовательность, если это возможно.

Отличная надстройка! Спасибо!!

Подскажите, как прописать путь к ячейке в которой находится картинка для Image1 ? заранее, спасибо!

Спасибо Вам огромное!

Здравствуйте, Александр.
Событие Worksheet_Change реагирует только на ручное изменение ячеек (ну и на изменение макросом)
А чтобы на пересчёт реагировало, - тут надо использовать событие пересчета листа, - Worksheet_Calculate

Ну и код у вас ужасно длинный, - можно сделать проще:

Private Sub Worksheet_Calculate()
    On Error Resume Next
    Dim dVal(0 To 5), NewVal&, i&: Static LastVal&        ' переменная  LastVal& хранит значение и после завершения макроса
    dVal(0) = "1111111": dVal(1) = "1111000": dVal(2) = "1100110": dVal(3) = "1111001": dVal(4) = "1100111"
 
    NewVal = Val(Me.Range("BD49").Value)
    If NewVal <> LastVal Then        ' меняем видимость картинок, только если значение ячейки BD49 поменялось при пересчёте
        LastVal = NewVal
        For i = 1 To Len(dVal(NewVal)) ' перебираем все нолики и единички в dVal(2) = "1100110" (если NewVal = 2)
            Me.Shapes(i).Visible = CBool(Mid(dVal(NewVal), i, 1)) ' меняем видимость картинки
        Next
    End If
End Sub

Здравствуйте.
Пытаюсь решить такую задачу: при изменении значений ячеек изменять видимость картинок.
когда вручную указываю значение - макрос включает и выключает картинки, а когда изменение значения ячейки вызвано результатом вычислений формул - макрос не работает. Пробовал указывать в макросе тип число, тип текст у переменной, которая принимает значение моей ячейки, саму ячейку умножал на 1 для получения типа число - бесполезно. Код следующий:

Private Sub Worksheet_Change(ByVal Target As Range)
Dim dVal As Integer
If Not Intersect(Target, ActiveSheet.Range("BD49")) Is Nothing Then
dVal = ActiveSheet.Range("BD49").Value

If dVal = 0 Then
With ActiveSheet
.Shapes.Item(1).Visible = True
.Shapes.Item(2).Visible = True
.Shapes.Item(3).Visible = True
.Shapes.Item(4).Visible = True
.Shapes.Item(5).Visible = True
.Shapes.Item(6).Visible = True
.Shapes.Item(7).Visible = True
End With

ElseIf dVal = 1 Then
With ActiveSheet
.Shapes.Item(1).Visible = True
.Shapes.Item(2).Visible = True
.Shapes.Item(3).Visible = True
.Shapes.Item(4).Visible = True
.Shapes.Item(5).Visible = False
.Shapes.Item(6).Visible = False
.Shapes.Item(7).Visible = False
End With

ElseIf dVal = 2 Then
With ActiveSheet
.Shapes.Item(1).Visible = True
.Shapes.Item(2).Visible = True
.Shapes.Item(3).Visible = False
.Shapes.Item(4).Visible = False
.Shapes.Item(5).Visible = True
.Shapes.Item(6).Visible = True
.Shapes.Item(7).Visible = False
End With

ElseIf dVal = 3 Then
With ActiveSheet
.Shapes.Item(1).Visible = True
.Shapes.Item(2).Visible = True
.Shapes.Item(3).Visible = True
.Shapes.Item(4).Visible = True
.Shapes.Item(5).Visible = False
.Shapes.Item(6).Visible = False
.Shapes.Item(7).Visible = True
End With

ElseIf dVal = 4 Then
With ActiveSheet
.Shapes.Item(1).Visible = True
.Shapes.Item(2).Visible = True
.Shapes.Item(3).Visible = False
.Shapes.Item(4).Visible = False
.Shapes.Item(5).Visible = True
.Shapes.Item(6).Visible = True
.Shapes.Item(7).Visible = True
End With

End If
End If
End Sub

Буду очень благодарен за помощь, рязъяснения в моих возможных заблуждениях.

Спасибо большое, попробовала, все работает. Сори что загрузила глупым вопросом)

Анастасия, в Excel есть кнопка «сжать рисунки» (при выделении одной или нескольких картинок на ленте появляется вкладка «Работа с рисунками», где присутствует эта кнопка)
Выделите все рисунки, нажмите кнопку, сохраните потом файл, - и всё.
Сделать это макросом, - не получится (только вручную)

Игорь, здравствуйте! Не знаю сможете мне подсказать или нет, но была бы крайне признательна... У меня такая проблема. Из 1с выгружаю в эксел прайс (уже с картинками), причем программа настроена так, что окошко для картинки я могу задать любое и именно под размер этого окошка оно будет уменьшаться. НО по сути хотя оно и выводится в прайс небольшим окошком - вставляется не уменьшенными пикселями, а полноценно - просто маленького вида, т.е. при растягивании фото в эксел в ручную - я вижу полноценную большую качественную фотографию. Таким образом файл этот весит неимоверно много отправлять такой клиентам не реально, а как сжать его я не могу найти решения (перевод в сжатый пдф очень портит вид картинки, что даже особо и не поймешь что там изображено). Откровенно говоря ничего не понимаю в макросах... Но если есть какой-то вариант решения ыопроса - буду разбираться.

Вопрос. При отправки таблицы с фотографиями через почту майл фотографии переворачиваются в таблице. Что делать?

Огромное спасибо.

Игорь, вам подойдёт такая формула:
SUBSTITUTE({text},"/","")

Здравствуйте. У меня проблема с поиском картинок в папке. Имеется артикул вида "123/123", а название фото "123123". Возможно при поиске удаление символа "/" с помощью формулы для обработки имени файла в вкладке дополнительно? Если да до подскажите формулу. Заранее спасибо.

Можете ли помочь? У меня такая проблема... Я выгружаю из 1С таблицу как HTML.
После чего вызываю Aplication.Excel, открываю им этот файл (Open), и делаю SaveAs как XLS.
Все бы отлично, но картинка в таблице сохраняется как ссылка на неё (сама картинка не сохраняется в файл).
И при передаче XLS-файла в нем картинки нет, только надпись, что картинка была перемещена или удалена...

Можно ли изменить картинку в экселе таким образом, чтобы она при сохранении сохранилась в само тело XLS?
Если такая возможность есть, объясните, как это вообще делать (я надеюсь сам перекладу на 1С алгоритм, мне главное понять суть).
Заранее спасибо...

П.С. нужно для экспорта из старой 1С платформы (которую не разрешают обновлять) в которой была проблема экспорта в эксель (выгружался с ошибками).

Андрей, я бы так попробовал:
(моё предположение: если вы картинку поворачиваете, - ширина картинки должна подгоняться не под ширину ячейки, а под высоту ячейки.)

    If AdjustWidth Then        ' высоту не трогаем - изменяем ширину
        If K_picture < 1 Then        ' картинка с поворотом
            ' возможно, надо не разделить на коэффициент, а умножить
            ph.Height = PicRange.Width: ph.Width = ph.Height / K_picture
            ph.ShapeRange.Rotation = -90
        Else
            ' картинка без поворота
            ' код не меняем
            ph.Width = PicRange.Width: ph.Height = ph.Width / K_picture
        End If
    End If

PS: код не проверял

Большое спасибо за макрос!
Всё отлично работает!

Подскажите, можно ли изменить функцию, чтобы картинки в портретной ориентации переворачивались в альбомную. Вставляю с подгонкой ячейки по высоте.
Я попробовал добавить в функцию строчку вот так:

    If AdjustPicture Then    ' ПОДГОНЯЕМ РАЗМЕРЫ ИЗОБРАЖЕНИЯ под ячейку (оптимальный вариант)
    
        ' если K_picture меньше 1, поворачиваем на 90 CCW
        If K_picture < 1 Then ph.ShapeRange.Rotation = -90

Картинка вставляется, вращается, но вставляется с сильным смещением вниз и влево.
Не могу понять, что я делаю не так.

Здравствуйте, Ольга.
Готового макроса нет, - под каждый тип файла надо делать отдельный макрос,
и эти макросы получатся очень сложными (дорогими)

Куда проще перевести (вручную или спец программами) PDF и JPG в формат Word, - и подставлять данные в этот шаблон Word
Для этой задачи есть готовое решение: http://excelvba.ru/programmes/FillDocuments
Можно сделать вывод результата в формат PDF (в вышеуказанной надстройке есть такая опция)
Если очень надо, - результат (заполненный документ Word или Excel) можно преобразовать и в картинку (JPG), написав отдельный макрос.

Здравствуйте, есть ли макрос для вставки значений из Excel в файлы PDF, JPG (или другие картинки)?

Спасибо.

замените Selection на pic

Спасибо. То, что Эксель вставит картинку ссылкой - не страшно. Даже хорошо. Изменив картинку изменю ее и в файле.
Подскажите, пожалуйста, как сдвинуть картинку чуть влево и чуть вверх.
До этого использовал:
Selection.ShapeRange.IncrementTop -4.5
Selection.ShapeRange.IncrementLeft -24.75
Но с новым кодом не работает.

Макрос для обрезки картинки:

Sub CropImage()
    Filename$ = "C:\Users\Игорь\Desktop\IMG_12082014_222844.png"
 
    Dim pic As Picture
    Set pic = ActiveSheet.Pictures.Insert(Filename$) ' вставка на лист
    
    With pic.ShapeRange.PictureFormat ' сколько с какой стороны обрезать
        .CropLeft = 50
        .CropTop = 60
        .CropBottom = 70
        .CropRight = 80
    End With
End Sub

PS: в Excel 2010 (и новее) ваш код вставит картинку именно ссылкой (а не внедрит её в книгу Excel)
Тут где-то ниже в комментах я приводил пример кода, как надо вставлять изображение, чтобы оно с файлом сохранилось

Друзья. Я вставляю картинку картинкой, а не ссылкой. Макрос просто записал.

Вот в чем вопрос: как сделать макрос для обрезки картинки? У картинки по бокам белые поля, их надо убрать.
Пробовал включить запись макроса и обрезать картинку. Все отлично, но при исполнении записанного макроса картинка не обрезается.

Код такой:
Sub Макрос3()
Range("C5").Select
ActiveSheet.Pictures.Insert( _
Excel.Application.ActiveWorkbook.Path & "\Превью А.jpg" _
).Select
Selection.ShapeRange.IncrementTop -4.5
Selection.ShapeRange.IncrementLeft -24.75
Selection.ShapeRange.LockAspectRatio = msoFalse
Selection.ShapeRange.IncrementLeft 22.6299212598
Selection.ShapeRange.PictureFormat.Crop.PictureWidth = 300
Selection.ShapeRange.PictureFormat.Crop.PictureHeight = 164
Selection.ShapeRange.PictureFormat.Crop.PictureOffsetX = 0
Selection.ShapeRange.PictureFormat.Crop.PictureOffsetY = 0

Range("O5").Select
ActiveSheet.Pictures.Insert( _
Excel.Application.ActiveWorkbook.Path & "\Превью Б.jpg" _
).Select
Selection.ShapeRange.IncrementTop -4.5
Selection.ShapeRange.IncrementLeft -24.75
Selection.ShapeRange.LockAspectRatio = msoFalse
Selection.ShapeRange.IncrementTop 4.5354330709
Selection.ShapeRange.PictureFormat.Crop.PictureWidth = 300
Selection.ShapeRange.PictureFormat.Crop.PictureHeight = 164
Selection.ShapeRange.PictureFormat.Crop.PictureOffsetX = 0
Selection.ShapeRange.PictureFormat.Crop.PictureOffsetY = 0
End Sub

Посоветуйте, пожалуйста, как сделать макрос обрезки картинки.

Спасибо

Здравствуйте, Константин
Моя программа для этих целей не предназначена.
Решение (с подробной инструкцией) легко найти в интернете, если в Яндекс вбить фразу «Excel выбор фото из выпадающего списка»

Скажите пожалуйста, как можно вставлять изображение из из этого же файла excel (например, с другого листа)? Задача - нужно что бы просто менялся логотип на бланке при выборе значения из списка. И что бы этот файл был автономный (не привязан к диску/папке на определенном компьютере)

Попробовал сегодня вставить макрос, который с PicRange, в свой файл в Экселе 2007.
Картинка не пожелала выравниваться по ячейке непропорционально. Выравнивает либо по высоте либо по ширине,в зависимости от того, что раньше сработает. одновременно выоту и ширину не подгоняет. Видимо нужно юзать Shapes, так как Pictures устарел. Искать помощь времени не было, посему заюзал по быстрому надстройку. Текущую задачу решил, спасибо.

Вячеслав, это весьма проблематично
Макрос может отследить только события типа SelectionChange - изменение выделенного объекта, и то, это касается только ячеек;
или же отследить вставку листа или диаграммы, - но вставку картинки, увы, никак.

Можно попробовать с интервалом в 1 секунду проверять количество картинок на листе, - и, если оно увеличилось на 1, - делать вывод, что вставлена новая картинка.
Но это очень плохая идея, и очень сложный макрос получится.

Здравствуйте, с помощью какой функции можно отследить такое событие как вставка картинки в excel? То есть моя задача состоит в том чтобы макрос запускался по факту вставления картинки в excel пользователем.

Спасибо.

Самый простой вариант - копировать ячейку целиком (картинка тоже скопируется)

[B2].copy [E5]

Если же нужен «правильный» способ, - надо в цикле перебрать все картинки на листе, проверяя каждую, находится ли она над ячейкой B2 (анализируя свойство TopLeftCell, размеры картинки и размеры ячейки), и потом, найдя одну или несколько подходящих картинок, скопировать их, после чего позиционировать копию над ячейкой E5

Разницу в сложности чувствуете?) потому, просто копируйте ячейку с картинкой

Подскажите, пожалуйста, а как можно копировать рисунок из одной ячейки в другую.
Например, конкретно из ячейки B2 в ячейку E5?

Спасибо,
очень помогли!

Можно и код, - надо просто внимательнее было читать комменты...
http://excelvba.ru/code/PastePictures#comment-3126

там есть код, который вставляет картинку «нормально» (а не связь с файлом картинки)

Нашел, вы даете ссылку на надстройку (http://excelvba.ru/programmes/PastePictures).
А там не указан код, только ссылка для скачивания.
Хотелось бы увидеть способ реализации.
Можно?

Артём, почитайте комментарии к статье, - найдете ответ на свой вопрос.

Подскажите, пожалуйста, как можно сделать, чтобы рисунок вставлялся в Excel не как ссылка, а как рисунок.
Дело в том, что при данной вставке, если рисунок из папки удалить, то он не будет виден в Excel ...

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

Здравствуйте, а возможна ли данная реализация для подтягивания графиков из ексель, в презентацию поверпоинт? Попробовал самостоятельно разработать, вышло следующее:

' Импортирует все графики в презентацию
Dim counter As Long
 
Sub ImportGraphs()
    Dim fileName As String
    Dim i
 
    Dim xlApp As Object
    Dim xlWorkbook As Object
    Dim xlSheet As Object
 
    Set xlApp = CreateObject("Excel.Application")
 
    fileName = xlApp.GetOpenFilename("Excel Files (*.xls), *.xls")
 
    If fileName Like "" Then
    MsgBox ("Выберите файл для импортирования данных")
    Else
    xlApp.Workbooks.Open (fileName)
 
    Set xlWorkbook = xlApp.ActiveWorkbook
    xlApp.Visible = True
 
    counter = 1
 
    For Each xlSheet In xlWorkbook.Sheets
      If xlSheet.Name Like "Диаграмма*" Then
          xlSheet.ChartArea.Copy
          PasteGraphs
        Else
         If xlSheet.ChartObjects.Count > 0 Then
           For i = 1 To xlSheet.ChartObjects.Count
             xlSheet.ChartObjects(i).Chart.ChartArea.Copy
             PasteGraphs
           Next
         End If
 
       End If
    Next
 
    End If
 
    Set xlWorkbook = Nothing
    xlApp.Quit
    Set xlApp = Nothing
End Sub
 
Sub PasteGraphs()
   ActivePresentation.Slides.Add(Index:=counter, Layout:=ppLayoutBlank).Select
   ActiveWindow.Panes(2).Activate
   ActiveWindow.View.PasteSpecial ppPasteOLEObject, , , , , msoTrue
   '
   ' изменение размера вставленного объекта
    With ActiveWindow.Selection.ShapeRange
        .ScaleWidth 1, msoFalse, msoScaleFromBottomRight
        .ScaleHeight 1, msoFalse, msoScaleFromBottomRight
        .ScaleWidth 1, msoFalse, msoScaleFromTopLeft
        .ScaleHeight 1, msoFalse, msoScaleFromTopLeft
    End With
    counter = counter + 1
End Sub

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

Здравствуйте, Александр
Так есть же готовое решение, - ссылка на надстройку для вставки картинок есть в заголовке статьи:
http://excelvba.ru/programmes/PastePictures
Кстати, в этой надстройке, в меню ДОПОЛНИТЕЛЬНО, есть опция вывода на лист списка файлов из заданной папки.

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

Здравствуйте, Иван
Специально для тех, кто не может разобраться в коде,
я сделал надстройку для вставки картинок в Excel
Ссылка на её скачивание приведена в начале статьи.

Отправить комментарий

Содержание этого поля является приватным и не предназначено к показу.
CAPTCHA
Подтвердите, пожалуйста, что вы - человек:
  _      ____    _     _____      _      ____  
| | __ | _ \ | |_ |___ / / \ | _ \
| |/ / | |_) | | __| |_ \ / _ \ | |_) |
| < | _ < | |_ ___) | / ___ \ | _ <
|_|\_\ |_| \_\ \__| |____/ /_/ \_\ |_| \_\
Введите код, изображенный в стиле ASCII-арт.

Не получается применить макрос? Не удаётся изменить код под свои нужды?

Оформите заказ у нас на сайте, не забыв прикрепить примеры файлов, и описать, что и как должно работать.