Excel Макросы: Смена картинки при нажатии на соответствующую картинку

[Ak1ra]

При оптимизации своего нелегкого труда - продажи, решил подготовить визуальную таблицу с описанием и всеми характеристиками. Все здорово конечно получилось, но столкнулся с двумя проблемами, которые не могу никак решить, а именно:
1. Смена картинки в листе Описание для каждой коллекции при нажатии на соответствующую картинку на Главной или же в любой выбранной коллекции.
2. Я так понимаю нужно как-то привязать картинки к ячейкам?
3. В зависимости от смены картинки на листе с Описанием нужно чтобы в одной и той же ячейке (Столбец "А" "№№№) менялся номер артикула.

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

[Администратор]

Без макросов, в интернете есть такой пример (смотрите прикреплённый файл). В нём, в B7 выбирайте нужный пункт и будет изменяться рисунок.
В вашем файле такое можно сделать или у вас другой принцип?

[Ak1ra]

Пример посмотрел, но он мне не подходит.

[Администратор]

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

[Ak1ra]

Черт, у меня все-таки была надежда сделать это без макросов!
Много времени это займет?

[Администратор]

Изображения можно так вставлять с помощью макроса.
У изображения нужно сделать:
1) имя сделайте по такой схеме "Имя листа/Уникальное имя рисунка". Например: Главная/Рисунок 1. Имя можно изменить так: щёлкните по рисунку левой мышью - слева от строки формул укажите имя и нажмите Enter;
2) в описании пишите имя листа, куда надо копировать изображение. Описание находится здесь: щёлкните по изображению правой мышью - Размер и свойства... - раздел "Замещающий текст" - Описание;
3) изображению нужно назначить макрос. Для всех изображений будет один макрос. Сейчас в файле это метод "Программа".

У изображений нужно убрать гиперссылки, иначе макрос не запускается.

В файле я сделал пример для первого изображения на листе "Главная".

Чтобы выделить изображение и начать его настраивать, нажмите и удерживайте Ctrl и щёлкайте по нему левой мышью.

После открытия файла не забудьте разрешить макросы.

Сам макрос:

Макрос

Sub Макрос()
   
    Dim shSrc As Worksheet, shRes As Worksheet
    Dim shpSrc As Shape, shpRes As Shape
   
    Set shSrc = Worksheets(Split(Application.Caller, "/")(0))
    Set shpSrc = shSrc.Shapes(Application.Caller)
   
    Set shRes = Worksheets(shpSrc.AlternativeText)
    shRes.Shapes(1).Delete
    shpSrc.Copy
    shRes.Range("B2").PasteSpecial
    Set shpRes = shRes.Shapes(1)
   
    shpRes.LockAspectRatio = False
    shpRes.Width = shRes.Range("B2:C20").Width
    shpRes.Height = shRes.Range("B2:C20").Height
   
End Sub

[свернуть]

[Ak1ra]

РАБОТАЕТ!!! Спасибо! Гениально! Дописал еще "shRes.Activate" в конце т.к. перехода на нужную страницу не было, но сути дела не меняет! Жаль конечно что все гиперссылки придется рубить, столько времени на них убил... Но результат того стоил.

Я могу к тебе обратиться со вторым вопросом, как быть с артикулами? Я могу обозвать все картинки соответствующими артикулами, а вот как вывести "название" (он же артикул) в соответствующую ячейку? Выручишь неимоверно!

[Администратор]

Я добавил в описание изображения артикул. Теперь в описании пишите по такой схеме: имя листа, на которой надо вставить/Артикул. Пример: Alignment описание/арт. 1

Макрос

Sub Макрос()
   
    Dim shSrc As Worksheet, shRes As Worksheet
    Dim imgSrc As Shape, imgRes As Shape
    Dim spl
   
   
    '1. Application.Caller вернёт имя рисунка, по которому щёлкнули.
        ' Имя рисунка можно посмотреть так: щёлкните по рисунку левой мышью -
        ' посмотрите слева от строки формул.
        ' Split разобьёт имя рисунка на части по слешу и будет получен массив, состоящий из двух элементов.
        ' Порядковый номер первого элемента в таком массиве 0.
    spl = Split(Application.Caller, "/")
   
    '2. Присваиваем листу-источнику программное имя "shSrc", чтобы удобно обращаться к нему.
        ' spl(0) - это первый элемент массива "spl" и в нём находится имя листа, взятое из имени рисунка.
    Set shSrc = Worksheets(spl(0))
   
    '3. Присваивание программного имени "imgSrc" рисунку, по которому щёлкнули.
    Set imgSrc = shSrc.Shapes(Application.Caller)
   
    '4. Разбивка на части описания рисунка по слешу
        ' и присваивание программного имени "shRes" листу-результату.
    spl = Split(imgSrc.AlternativeText, "/")
    Set shRes = Worksheets(spl(0))
   
    '5. Удаление на листе-результате рисунка.
    shRes.Shapes(1).Delete
   
    '6. Копирование рисунка из листа-источника и вставка его на лист-результат.
    imgSrc.Copy
    shRes.Range("B2").PasteSpecial
   
    '7. Разбивка текста в описании рисунка на части по слешу и запись артикула в эксель-ячейку.
        ' 2 - означает, что текст будет разбит на две части. Это нужно на случай,
        ' если в самом артикуле будут слеши, чтобы артикул не разбился на части.
    spl = Split(imgSrc.AlternativeText, "/", 2)
    shRes.Range("A10").Value = spl(1)
   
    '8. Присваивание программного имени вставленному рисунку.
    Set imgRes = shRes.Shapes(1)
   
    '9. Убираем галочку "Сохранять пропорции", чтобы задать нужную высоту и ширину.
        ' И задаём размеры рисунку по размеру занимаего им эксель-фрагмента.
    imgRes.LockAspectRatio = False
    imgRes.Height = shRes.Range("B2:C20").Height
    imgRes.Width = shRes.Range("B2:C20").Width
   
    '10. Переход на лист-результат.
    shRes.Activate
   
End Sub

[свернуть]

[Ak1ra]

Всё работает как часы! Мои искренние благодарности и почтение!