Фото-каталог товаров в Excel

[Fellow]

Здравствуйте.
Прошу всех помощи, как закончить код, и дать критические замечания по структуре кода (полагаю, что код содержит много лишнего).Приведенный код – это мой первый опыт в программировании. Он создавался частями из примеров уважаемых людей. Сейчас я дошел до момента, когда формируется только каталог с фотографиями, но не понимаю, как добавить текстовое описание для каждой фотографии.
Опишу, что получается при работе кода:
1. В колонке А перечислены артикулы, которые являются фрагментами названий графических файлов (фотографий товаров, например, с расширением *.jpeg, *.tif и другие), расположенные в какой-либо папке на жестком диске. При нажатии на кнопку «Получить путь» формируется массив из артикулов (фрагментов названий файлов) и вызывается диалоговое окно для выбора пользователем пути к папке, где находятся файлы с фотографиями этих артикулов. Далее создается объект File System Object, который получает все названия файлов в выбранной пользователем папке (а также получает все названия файлов из подпапок в выбранной папке). Если артикул содержится в имени файла, то выводится путь к этому файлу в ячейку, смещенную вправо (то есть в ячейку колонки В напротив совпавшего артикула).
2. После выполнения кода из пункта 1 в колонке B для каждого артикула создан путь к файлу. При нажатии на кнопку «Создать каталог» формируется массив «пути к файлам» по колонке B. Далее создается новый документ Excel, в котором задается диапазон (в данном случае [b3:c3]) для вставки первой фотографии и последующих через определенное кол-во строк. В итоге получается каталог фотографий в новом документе Excel, расположенный в порядке, соответствующий порядку расположения артикулов в колонке А на 1 листе исходного документа.
Это пока весь функционал программы.

Опишу, что в итоге нужно получить (где нужна помощь):
3.При формировании каталога в новом документе Excel нужно добавить текстовое описание для каждой фотографии:
Перед вставкой первой фотографии и последующей нужно вставлять, например, для первого артикула в ячейку А2 заголовок столбца «Артикул:» и сам артикул в ячейку B2 для этой фотографии из исходного документа.
После вставки первой фотографии и последующей нужно вставлять, например, для первого артикула: в ячейке А5 «Страна происхождения:», а в ячейке B5 «Китай»; в ячейке A6 “Производитель:”, а в ячейке B6 “China Corp”.
Очень важно учесть: в исходном документе справа от колонки «полный путь к файлу» может быть от 1 до 10 столбцов, ячейки которых могут, как содержать информацию, так и быть пустыми. При наличии в исходном документе дополнительных столбцов и заполненных ячеек в этих столбцах в новый документ вставляется заголовок столбца и текстовое значение ячейки (из этого столбца), описывающее определенную фотографию.
Вот, как-то так

[EducatedFool]

В коде, конечно, много лишнего, но... разве это важно?

Я могу убрать весь лишний код - но это займёт много времени.
Поэтому предлагаю вам ещё один пример с ОГРОМНЫМ количеством лишнего кода:
http://excelvba.ru/XL_Files/Sample__...__14-37-02.zip
(при нажатии на зелёную кнопку запуска формируется таблица с фотографиями - для каждой позиции скачивается с интернета (или вставляется с компа) 2 фотографии, добавляются подписи для этих фотографий, добавляются гиперссылки с фотографий на пункты основной таблицы, и т.д.)
Также реализована функция обрезки краёв некоторых типов фотографий (функция CropPicture)

PS: А у вас картинки могут располагаться и в подпапках выбранной папки?
Если нет - то код можно значительно упростить.

=============== добавлено позже ====================

У меня на сайте есть готовая программа для вставки изображений на лист Excel:
http://excelvba.ru/programmes/PastePictures

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

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




Особенности надстройки вставки изображений:

• загрузка изображений по ссылкам (обычная гиперссылка, просто текст ссылки - URL, формула =ГИПЕРССЫЛКА(), и т.п.)
• поиск картинок в подпапках заданной папки (глубина поиска по подпапкам не ограничена)
• установка выбранного пользователем размера для вставляемых изображений
• отображение состояния поиска и вставки изображений (прогресс-бар)
• вывод результатов обработки таблицы (сколько изображений вставлено, сколько не найдено)
• добавление гиперссылок к вставляемым изображениям (по щелчку на картинке открывается исходный файл)
• 2 режима поиска файлов - по точному совпадению имени файла, и по началу имени файла-изображения
• 2 режима вставки картинок - подгонка размеров под ячейку, или соблюдение пропорций исходного изображения
• вывод количества файлов в выбранной папке
• возможность выбора столбца с названиями файлов, и указания номера столбца для вставляемых изображений
• возможность вставки изображений в комментарии к ячейкам

Запуск вставки изображений выполняется из меню программы (на панели инструментов)

Надстройка вставки картинок в Excel теперь поддерживает обновления - поэтому отныне надстройка будет регулярно получать новые полезные функции.

Новый функционал будет добавляться в надстройку по мере поступления ваших пожеланий.

[Fellow]

Важно для меня - это решить задачу. А если задача будет решена красиво, то это будет еще и уроком для меня.

Спасибо за пример. Сейчас изучаю его. Пока есть одно затруднение - что значит [RowTemplate] и откуда этот образец строки берется?

Например, в функции:

Function TheTable() As Range
Dim ro As Range: Set ro = shs.[RowTemplate]
Debug.Print ro.Row
If ro.Row > 14 Then Set TheTable = shs.Range("14:" & (ro.Row - 1)).EntireRow
Debug.Print TheTable.Row
End Function

Картинки могут находиться и в подпапках выбранной папки. Они сгруппированы по папкам - готовые изделия, принадлежности к изделию, запасные части к изделию.

[EducatedFool]

что значит [RowTemplate] и откуда этот образец строки берется?

В строке Set ro = shs.[RowTemplate]
shs означает ссылку на лист с кодовым именем shs
[RowTemplate] - ссылка на именованный диапазон с именем RowTemplate на листе shs

Картинки могут находиться и в подпапках выбранной папки

Это плохо.
Иначе можно было бы искать картинки, не считывая изначально список всех файлов:
артикул="5587"
ПутьКФайлу = Dir (ПутьКПапке & "*" & артикул & "*.jpg")

В вашем случае такой вариант, увы, не подойдёт.

Для считывания имён файлов в коллекцию можно использовать эту функцию: http://excelvba.ru/code/FilenamesCollection

Я бы сделал вам пример - но...
1) сейчас пока нет времени
2) вы не выложили папку с картинками (не на чем тестировать макрос)
3) вы не показали на примере, как должен выглядеть отчёт с фотографиями (сделайте вручную на примере 2-3 фоток)

[Fellow]

[RowTemplate] - ссылка на именованный диапазон с именем RowTemplate на листе shs

Спасибо за разъяснения.

Для считывания имён файлов в коллекцию можно использовать эту функцию: http://excelvba.ru/code/FilenamesCollection

С этого примера я начал изучать, как решить свою задачу
В итоге использовал код из этого примера http://forum.ixbt.com/topic.cgi?id=23:38561

Я бы сделал вам пример - но...

Прикрепил картинки и ПримерФотоОтчета на случай, если все таки у Вас появится свободное время

[EducatedFool]

Сделал небольшой пример (правда, забыл учесть некоторые нюансы, но всё же).
Проверяйте:



Сделал, как и у вас, 2 макроса:

Sub ПолучитьПутиКФайлам()
    ' Ищем в выбранной апаке все файлы JPG, и выводим на лист список их имён.
    Dim coll As Collection, ПутьКПапке As String
    СтартоваяПапка = "C:\Documents and Settings\Admin\Рабочий стол\"    ' укажите здесь свою папку

    ' отображаем диалоговое окно выбора папки
    ПутьКПапке = GetFolderPath("Выберите папку на рабочем столе", СтартоваяПапка)
    If ПутьКПапке = "" Then Exit Sub    ' выход, если пользователь отказался от выбора папки

    Set coll = FilenamesCollection(ПутьКПапке, ".jpg")    ' считываем в колекцию coll нужные имена файлов

    Application.ScreenUpdating = False    ' отключаем обновление экрана
    On Error Resume Next    ' на случай, если на листе нет артикула для найденной картинки

    ' выводим результаты на лист
    For Each file In coll    ' перебираем все пути к файлам
        артикул = Val(Dir(file))    ' выдираем артикул (цифровое значение) из имени файла
        ' ищем артикул в первом столбце, и, если находим,
        ' в ячейку справа пишем полный путь к файлу картинки
        shs.Range("a:a").Find(артикул, , , xlWhole).Next = file
    Next file

    shs.Range("b:b").EntireColumn.AutoFit    ' автоподбор ширины столбца
End Sub

' путь к файлу картинки "по умолчанию" - если путь к картинке не найден
Const DefaultPicturePath = "C:\WINDOWS\Web\Wallpaper\Ветер.jpg"

Sub ФормированиеОтчёта()
    ' диапазон с артикулами
    Dim ra As Range: Set ra = shs.Range(shs.[A2], shs.Range("A" & shs.Rows.Count).End(xlUp))

    Dim sh As Worksheet: Set sh = ThisWorkbook.Worksheets.Add(, shs)     ' добавляем новый лист
    sh.Name = "Отчёт " & Format(Now, "DD_MM_YYYY HH-NN-SS")    ' присваеваем листу имя
    sh.Tab.Color = vbGreen

    Dim cell As Range, n As Long: Application.ScreenUpdating = False
    For Each cell In ra.Cells    ' перебираем все артикулы
        n = n + 1: ДобавитьБлок sh, n, cell.EntireRow    ' создаём новый блок в отчёте
    Next cell
    sh.Range("c:c").HorizontalAlignment = xlRight
End Sub

[EducatedFool]

Если отчёт нужен в новом файле, замените строку

Dim sh As Worksheet: Set sh = ThisWorkbook.Worksheets.Add(, shs)     ' добавляем новый лист

на

Dim sh As Worksheet: Set sh = Workbooks.Add(xlWBATWorksheet).Worksheets(1)     ' первый лист в новой книге

Очень важно учесть: в исходном документе справа от колонки «полный путь к файлу» может быть от 1 до 10 столбцов, ячейки которых могут, как содержать информацию, так и быть пустыми.

В этом случае при получении данных надо указывать не конкретные номера столбцов, как здесь

    BlockFirstCell.Offset(2, 2) = ro.Cells(3)  ' вставляем страну
    ...
    BlockFirstCell.Offset(3, 2) = ro.Cells(4)  ' вставляем Производителя

а сначала искать нужные заголовки столбцов, и потом брать значения на пересечении этих столбцов и текущей строки ro

[Fellow]

Все работает точно так, как я описал

Решил, что число названий столбцов должно быть переменным и получать их лучше из исходного документа, а вставку в блок после картинки производить через цикл.

Sub ФормированиеОтчёта()
    ' диапазон с артикулами
    Dim ra As Range: Set ra = shs.Range(shs.[A2], shs.Range("A" & shs.Rows.Count).End(xlUp))
    'получает диапазон названий столбцов
    Dim Шапка As Range: Set Шапка = shs.Range(shs.[A1], Cells(1, Columns.Count).End(xlToLeft).Address)
    
    Dim sh As Worksheet: Set sh = ThisWorkbook.Worksheets.Add(, shs)     ' добавляем новый лист
    sh.Name = "Отчёт " & Format(Now, "DD_MM_YYYY HH-NN-SS")    ' присваеваем листу имя
    sh.Tab.Color = vbGreen
    Dim cell As Range, n As Long: Application.ScreenUpdating = False
    For Each cell In ra.Cells    ' перебираем все артикулы
        n = n + 1: ДобавитьБлок sh, n, cell.EntireRow, Шапка.Cells.Count + 2, Шапка ' создаём новый блок в отчёте
    Next cell
    sh.Range("c:c").HorizontalAlignment = xlRight
End Sub

Sub ДобавитьБлок(ByRef sh As Worksheet, ByVal n As Long, ByRef ro As Range, ByVal КолвоСтрокВБлоке As Long, ByRef Шапка As Range)
    ' процедура создания нового блока в отчёте
    ' в качестве параметров принимает:
    ' 1) sh - ссылка на лист отчёта
    ' 2) n - порядковый номер блока
    ' 3) ro - ссылка на строку с данными для блока
    ' 4) КолвоСтрокВБлоке - количество строк в блоке
    ' 5) Шапка - наименований столбцов
    On Error Resume Next
    ' ищем первую ячейку для блока
    Dim BlockFirstCell As Range: Set BlockFirstCell = sh.Range("b" & (n - 1) * КолвоСтрокВБлоке + 1)
    ' вставка данных в блок
    BlockFirstCell.Next = Шапка.Cells(1) 'вставляем "Артикул:"
    BlockFirstCell.Next.Next = ro.Cells(1) ' вставляем артикул
    
    ' если путь к картинке не указан - вставляем картинку "по умолчанию"
    ПутьККартинке = IIf(Trim(ro.Cells(2)) = "", DefaultPicturePath, ro.Cells(2))
    ВставитьКартинку BlockFirstCell.Offset(1).Resize(, 3), ПутьККартинке
    
    'вставка данных в блок после картинки
    For i = 2 To Шапка.Cells.Count
    'если вставляемая ячейка в блок не содержит значение - переходим к следующей ячейке
    If ro.Cells(i + 1) > 0 Then
    BlockFirstCell.Offset(i, 1) = Шапка.Cells(i + 1)
    BlockFirstCell.Offset(i, 2) = ro.Cells(i + 1)
    End If
    Next i

Но, если вставляемая ячейка в строку блока не содержит значение, тогда эта строка в блоке остается пустой и осуществляется переход следующей к ячейке.

Каким образом можно удалять пустые строки из блока?