Страницы: 1
RSS
Подбор рисунка по наименование
 
Добрый день!

Есть исходные данные: наименование предмета и его изображение.
Необходимо в новой таблице подтянуть изображения предметов по наименованию из первой таблицы.

Подскажите, как можно это сделать?
Во вложении пример. В оригинальном файле более 50 наименований, при формировании отчетов и сводных таблиц приходится делать вручную.
 
Выбор фото из выпадающего списка
Согласие есть продукт при полном непротивлении сторон
 
Sanja, добрый день!
Мне нужно, чтобы, например, при создании новой книги,  я мог по наименованию продукции подтягивать из исходной таблицы картинки. Как использование ВПР, но вместо текстового значения подбираются картинки.
В вашем случае, если я не ошибаюсь, я создаю список для одной ячейки, где при изменении наименования выпадает нужная картинка. Мне интересен случай, когда рисунки расставляются напротив наименования в разных ячейках, без выпадающего списка.
Во вложении расширенный пример. Надеюсь, что я сумел объяснить возникший вопрос.
 
Как-то так:
Код
Sub test()
Dim LastRow As Long
Dim myArray() As Variant
LastRow = Worksheets(1).Cells.SpecialCells(xlCellTypeLastCell).Row
Worksheets(1).Activate
myArray = Range(Cells(1, 1), Cells(LastRow, 2))
For i = 2 To Worksheets(2).Cells.SpecialCells(xlCellTypeLastCell).Row
    cl = Worksheets(2).Cells(i, 1).Value
    For i2 = 1 To UBound(myArray)
        If cl Like myArray(i2, 1) Then
            Worksheets(1).Cells(i2, 2).Copy
            ActiveSheet.Paste Destination:=Worksheets(2).Cells(i, 3)
        End If
    Next
Next
Worksheets(2).Activate
End Sub
Изменено: magistor8 - 17.01.2019 10:05:23
 
Если я не ошибаюсь, то Вы добьетесь успеха, повторив 4й и 5й шаги указанного выше приема для всех ячеек нужного Вам диапазона в новой таблице.
Если же Вам не требуется выпадающие списки, то решение можно даже несколько упростить, заполнив вручную "левый" столбец таблицы нужными значениями.
 
magistor8
Не удаляет предыдущие рисунки. Сверху и сверху записывает.

Попробуйте :)
 
magistor8, большое спасибо!
Буду разбираться в синтаксисе макроса.
Также в интернете находил пример со следующим макросом, тоже буду смотреть по синтаксису. Недостаточность моих познаний макросов не позволяет сразу понять алгоритм их работы. Надеюсь, что смогу разобраться.
Также оставлю найденный мной пример, если кому пригодится
Код
 Application.ScreenUpdating = False
    Dim iLastrow As Integer, i As Integer
    Dim iLastRow2 As Integer
    Dim s As Integer
    Dim sh1 As Worksheet, sh2 As Worksheet
    Set sh1 = Sheets("лист1")
    Set sh2 = Sheets("лист2")
    iLastrow = sh2.Cells(Rows.Count, 1).End(xlUp).Row
    iLastRow2 = sh1.Cells(Rows.Count, 1).End(xlUp).Row
    For i = 2 To iLastrow
        sh1.Range("a2:a" & iLastRow2).Find(what:=sh2.Cells(i, 1).Value, LookIn:=xlValues).Offset(0, 3).Copy
        sh2.Activate
        sh2.Cells(i, 6).Select
        ActiveSheet.Pictures.Paste(Link:=True).Select
    Next i
    Application.ScreenUpdating = True
End Sub
 
Цитата
zlipse написал:
Не удаляет предыдущие рисунки.
Да, надо предварительно очищать их
Код
For Each s In ActiveSheet.Shapes
    If Not s.Name Like "Button*" Then
    s.Delete
    End If
Next
 
zlipse, немного другой функционал, но в определенных ситуациях поможет.
Спасибо!
Страницы: 1
Наверх