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

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


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

Новости:

К первому сообщению темы должен быть прикреплен файл примера в формате xls*.
Приложив пример, Вы избавите себя и других от вопросов типа "А какой критерий?", "А куда выводить результат?", "А сколько строк?" и все тех же просьб выложить файл. Рисовать за Вас Ваши же таблички с заданиями, а затем и решение к ним, никто желанием не горит. Да и, как показывает практика, в большинстве случаев без файла решения не найти.

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

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

runner

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

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

Модуль берёт название картинки(в виде артикул.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

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

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

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

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

runner

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

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

boa

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

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

boa

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

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

runner

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

Всё ли я так сделал?
не срабатывает.
Логика пути - общий ресурс диск 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

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

Всё ли я так сделал?
не совсем
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
  • Оффлайн Оффлайн
  • Сообщений: 145

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

boa

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

Теперь всё идеально!
позвольте усомниться ;)
в вашем коде надо выделять ячейки только в колонке с артикулами.
Не большое преобразование и можно оторваться от этой привязки...
В строки, которые попали в любое выделение ячеек(только не пытайтесь выделить целые столбцы, иначе надо будет еще преобразрвывать...), будут вставлены картинки в 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
  • Оффлайн Оффлайн
  • Сообщений: 145

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

Записан

boa

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

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



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

30.09.2018 10:24 Расчет процентов за определенный период (месяц) с учетом изменений и платежей 390
03.03.2018 00:00 Подсчет отработанного времени, за исключением заранее определенных перерывов 1183
14.02.2018 10:11 Подготовить читабельную отчетность по платежам 1183
23.01.2018 13:46 Найти вероятность повторной покупки 1077
12.01.2018 23:56 Сделать отчет на Power BI (Dashboard) 1512
06.09.2017 10:43 Solver VBA не решает гиперболическое уравнение, но при этом решает гармоническое 1365
17.08.2017 12:15 Гиперссылка и фильтр одновременно макрос 1714
23.05.2017 11:20 Копирование данных из одной таблицы в умную таблицу по условию 3470
15.03.2017 15:45 автозамена картинок PowerPoint 1968
11.03.2017 13:43 Изменить нумерацию страниц 2097





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

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