И опять про вставку картинок

[Even]

Добрый день, знатоки. Не подскажите, можно ли сделать так, что бы при нажатии кнопки на странице, все картинки, из определённой папки, (название картинок каждый раз новое) вставали только в определённые ячейки, не хоотичнок, как обычно.

[EducatedFool]

Картинок всегда только три, или может быть больше?
Вставку производить в один столбец?
Объединять ячейки обязательно? Или вставку производить только в заранее подготовленные объединённые ячейки?
Или, может, просто увеличивать высоту строк, в которые будут вставляться картинки?
Что делать, если объединённых ячеек меньше, чем картинок?
Почему между кратинками разное расстояние по вертикали? (5 и 6 строк соответственно)
Куда помещать четвертую картинку (если таковая будет)?
Картинки подгонять по ширине, по высоте, или растягивать (непропорционально) под размер ячейки?

[Even]

Во вложении пример. А вообще картинок будет порядка десяти (поразному). Вставка в один столбец. Ячейки объдинянь не обязательно (будет бланк). Растояние между строками будет одинаковое (4 строки). Подгонять картинки надо (я бы сделал).

[EducatedFool]

Попробуйте такой вариант:



(замените свой файл моим)

Вот весь код:

Sub Main()
    On Error Resume Next
    ' там же, где и этот файл, в подпапке "Картинки"
    ПутьКПапкеСКартинками = Replace(ThisWorkbook.FullName, ThisWorkbook.Name, "Картинки\")

    Application.ScreenUpdating = False: msg = ""
    Dim sh As Worksheet: Set sh = ActiveSheet
    Очистка    ' очистка всех ячеек листа от прежнего содержимого
    Dim coll As New Collection
    Filename = Dir(ПутьКПапкеСКартинками & "*.jpg")
    While Filename <> ""
        coll.Add ПутьКПапкеСКартинками & Filename
        Filename = Dir
    Wend

    Dim ra As Range: Application.ScreenUpdating = False
    Set ra = [b4:e4]    ' место для первой картинки
    For Each Filename In coll
        ВставитьКартинку ra, Filename
        Set ra = ra.Offset(5)
    Next
    Application.ScreenUpdating = True
End Sub

Sub Очистка()
    Dim sha As Shape: Application.ScreenUpdating = False
    For Each sha In ActiveSheet.Shapes
        If sha.Type = msoPicture Then sha.Delete
    Next
    ActiveSheet.UsedRange.EntireRow.AutoFit
End Sub

Sub ВставитьКартинку(ByRef cell As Range, ByVal Pic As String)
    On Error Resume Next
    Dim ph As Picture: Set ph = cell.Parent.Pictures.Insert(Pic)
    ph.Top = cell.Top: ph.Left = cell.Left: k = ph.Width / ph.Height
    ph.Width = cell.Width: ph.Height = ph.Width / k
    cell.EntireRow.RowHeight = ph.Height
End Sub

[Even]

Спасибо, о великий Гуру.

[nikitan95]

Доброго)

Пожалуйста, помогите со следующей ситуацией: надо было составить БД автомашин с их картинками. Сделал в двух листах. В первом - общий список со всеми техн.характеристиками (в т.ч. картинки), а во-втором просмотр, через выпадающий список (выбирается машина с госномером, а остальные поля автоматом заполняются через функцию ВПР). Все работает путем, а вот как вставить показать картинки соответственно но машинам, ну никак мне не удалось. Помогите, пожалуйста, прошу. Желательно без макросов.

Заранее благодарный -
Нишон)

[alex77755]

Может это тебе поможет

[nikitan95]

alex77755 спасибо конечно, но файл поврежден((

[nikitan95]

alex77755, извиняюсь, открыл но я действовал именно по этой статье) по спасибо за сочувствие...