Профессиональные приемы работы в Microsoft Excel

Пожалуйста, войдите или зарегистрируйтесь.


Расширенный поиск  

Новости:

Из правил форума: Тема должна отражать суть вопроса, топики типа "help please" будут удаляться!

Автор Тема: Вставка картинок по данным из двух столбцов  (Прочитано 131 раз)

0 Пользователей и 1 Гость просматривают эту тему.

runner

  • Постоялец
  • ***
  • Уважение: +7/-0
  • Оффлайн Оффлайн
  • Сообщений: 144

Доброго дня всем читающим!
Есть код, полученный в этом же форуме (за что автору отдельное спасибо!), который хотелось бы модифицировать, но моих знаний для этого не хватает.

Модуль берёт название картинки(в виде артикул.jpg) из ячейки, добавляет его в конец прописанного пути R:\ФОТО\BOSCH\150\ и загружает картинку в ячейку справа от ячейки с названием.
Хочется, чтобы путь тоже был "составным", так как папок с картинками по брендам много, и каждый раз переписывать путь неудобно.
Надо чтобы название папки, в данном конкретном случае "BOSCH", бралось из ячейки слева от ячейки с названием картинки.
Результат должен выглядеть, как в приложенном файле.

Sub InsertPictures()
Const PATH = "R:\ФОТО\BOSCH\150\" 'папка с картинками
Dim c As Range
For Each c In Selection
   With ActiveSheet.Shapes.AddPicture(PATH & c, _
       msoFalse, msoTrue, c(, 2).Left, c(, 2).Top, 100, 100)
       .ScaleHeight 1, msoTrue, msoScaleFromTopLeft    'вернуть исходную высоту
       .ScaleWidth 1, msoTrue, msoScaleFromTopLeft     'вернуть исходную ширину
       c.RowHeight = .Height + 10                      'подстроить высоту строки
   End With
Next
End Sub

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

Записан

boa

  • Глобальный модератор
  • Старожил
  • *****
  • Уважение: +31/-0
  • Оффлайн Оффлайн
  • Сообщений: 519
  • Доброта спасет мир...

Здравствуйте,
закомментируйте(Удалите) строку, где добавляется Патч

и перед With ActiveSheet...добавьте
PATH = c.Offset(, -1).valueНо путь в ячейке 1 должен быть полным и заканчиваться слэшем "\".

Либо надо составлять дополнительный справочник путей для разных наименований и обращаться к нему
Записан
Ничто не обходится нам так дешево и не ценится так дорого, как вежливость...  Мигель Сервантес де Сааведра

runner

  • Постоялец
  • ***
  • Уважение: +7/-0
  • Оффлайн Оффлайн
  • Сообщений: 144

Спасибо!
Вполне рабочий вариант! Жаль, не удалось обойтись имеющимися столбцами, но требуемый выстраивается просто, так что - результат достигнут.
Кстати, у меня срабатывает как раз без слэша в конце, т.е. '...jpg' и всё
Записан

boa

  • Глобальный модератор
  • Старожил
  • *****
  • Уважение: +31/-0
  • Оффлайн Оффлайн
  • Сообщений: 519
  • Доброта спасет мир...

Но путь в ячейке 1 должен быть полным и заканчиваться слэшем "\".
Записан
Ничто не обходится нам так дешево и не ценится так дорого, как вежливость...  Мигель Сервантес де Сааведра

boa

  • Глобальный модератор
  • Старожил
  • *****
  • Уважение: +31/-0
  • Оффлайн Оффлайн
  • Сообщений: 519
  • Доброта спасет мир...

Совсем идеальным вариантом было бы, если и расширение файла с картинкой (.jpg) добавлялось бы в конец пути в коде, чтобы не создавать столбец дополнительно а использовать два столбца бренд/артикул)
Не знаю всей логики составления пути к файлу, но могу предположить вариант
Filename = "R:\ФОТО\" & c.Offset(, -1).Value & "\150\" & c.Value & ".jpg"соответственно "Filename" заменит в коде "PATH & c"
Записан
Ничто не обходится нам так дешево и не ценится так дорого, как вежливость...  Мигель Сервантес де Сааведра

runner

  • Постоялец
  • ***
  • Уважение: +7/-0
  • Оффлайн Оффлайн
  • Сообщений: 144

Всё ли я так сделал?
не срабатывает.
Логика пути - общий ресурс диск R:, на нём раздел ФОТО, в нём папки именованные названием бренда, внутри полноразмерные фото в формате артикул.jpg и папка под названием "150" в которой аналогичные фото с такими же названиями, но с максимальной высотой в 150 точек.
Собственно их и предполагается загружать в таблицу. 


Sub InsertPictures()
Dim c As Range
For Each c In Selection
   With ActiveSheet.Shapes.AddPicture(Filename = "R:\ФОТО\" & c.Offset(, -1).Value & "\150\" & c.Value & ".jpg", _
       msoFalse, msoTrue, c(, 2).Left, c(, 2).Top, 100, 100)
       .ScaleHeight 1, msoTrue, msoScaleFromTopLeft    'вернуть исходную высоту
       .ScaleWidth 1, msoTrue, msoScaleFromTopLeft     'вернуть исходную ширину
       c.RowHeight = .Height + 10                      'подстроить высоту строки
   End With
Next
End Sub
Записан

boa

  • Глобальный модератор
  • Старожил
  • *****
  • Уважение: +31/-0
  • Оффлайн Оффлайн
  • Сообщений: 519
  • Доброта спасет мир...

Всё ли я так сделал?
не совсем
Sub InsertPictures()
Dim c As Range
dim Filename as string
For Each c In Selection
Filename = "R:\ФОТО\" & c.Offset(, -1).Value & "\150\" & c.Value & ".jpg"
   With ActiveSheet.Shapes.AddPicture(Filename, _
       msoFalse, msoTrue, c(, 2).Left, c(, 2).Top, 100, 100)
       .ScaleHeight 1, msoTrue, msoScaleFromTopLeft    'вернуть исходную высоту
       .ScaleWidth 1, msoTrue, msoScaleFromTopLeft     'вернуть исходную ширину
       c.RowHeight = .Height + 10                      'подстроить высоту строки
   End With
Next
End Sub
Записан
Ничто не обходится нам так дешево и не ценится так дорого, как вежливость...  Мигель Сервантес де Сааведра

runner

  • Постоялец
  • ***
  • Уважение: +7/-0
  • Оффлайн Оффлайн
  • Сообщений: 144

Спасибо огромное! Теперь всё идеально!
Записан

boa

  • Глобальный модератор
  • Старожил
  • *****
  • Уважение: +31/-0
  • Оффлайн Оффлайн
  • Сообщений: 519
  • Доброта спасет мир...

Теперь всё идеально!
позвольте усомниться ;)
в вашем коде надо выделять ячейки только в колонке с артикулами.
Не большое преобразование и можно оторваться от этой привязки...
В строки, которые попали в любое выделение ячеек(только не пытайтесь выделить целые столбцы, иначе надо будет еще преобразрвывать...), будут вставлены картинки в 3-м столбце;)
Если, конечно, сгенерированный из значений 1-й и 2-й ячейки путь к картинке существует.
Sub InsertPictures()
Dim c As Range
Dim Filename As String
on error resume next
For Each c In Selection.EntireRow
Filename = "R:\ФОТО\" & c.Cells(1).Value & "\150\" & c.Cells(2).Value & ".jpg"
   With ActiveSheet.Shapes.AddPicture(Filename, _
       msoFalse, msoTrue, c.Cells(3).Left, c.Cells(3).Top, 100, 100)
       .ScaleHeight 1, msoTrue, msoScaleFromTopLeft    'вернуть исходную высоту
       .ScaleWidth 1, msoTrue, msoScaleFromTopLeft     'вернуть исходную ширину
       c.RowHeight = .Height + 10                      'подстроить высоту строки
   End With
Next
End Sub
« Последнее редактирование: 03.08.2018, 18:47:12 от boa »
Записан
Ничто не обходится нам так дешево и не ценится так дорого, как вежливость...  Мигель Сервантес де Сааведра

runner

  • Постоялец
  • ***
  • Уважение: +7/-0
  • Оффлайн Оффлайн
  • Сообщений: 144

У меня просто нет слов ..... этот модуль опередил мои следующие вопросы!  :D :D :D

Записан

boa

  • Глобальный модератор
  • Старожил
  • *****
  • Уважение: +31/-0
  • Оффлайн Оффлайн
  • Сообщений: 519
  • Доброта спасет мир...

Всегда ставьте себе максимальные цели, а лишь потом корректируйте свои "аппетиты" встретившимися ограничениями, и то, не все ограничения являются таковыми!
Постановка "полуцелей" - ошибка большинства.
Записан
Ничто не обходится нам так дешево и не ценится так дорого, как вежливость...  Мигель Сервантес де Сааведра
 



Темы без ответов

22.05.2018 11:38 Скрипт написать который допишет данные в файл 570
03.03.2018 00:00 Подсчет отработанного времени, за исключением заранее определенных перерывов 848
14.02.2018 10:11 Подготовить читабельную отчетность по платежам 821
23.01.2018 13:46 Найти вероятность повторной покупки 778
12.01.2018 23:56 Сделать отчет на Power BI (Dashboard) 1060
06.09.2017 10:43 Solver VBA не решает гиперболическое уравнение, но при этом решает гармоническое 1033
17.08.2017 12:15 Гиперссылка и фильтр одновременно макрос 1347
23.05.2017 11:20 Копирование данных из одной таблицы в умную таблицу по условию 2953
15.03.2017 15:45 автозамена картинок PowerPoint 1782
11.03.2017 13:43 Изменить нумерацию страниц 2013





Яндекс цитирования msexcel.ru Яндекс.Метрика

Страница сгенерирована за 0.123 секунд. Запросов: 121.