Домашняя страница Undo Do New Save Карта сайта Обратная связь Поиск по форуму
МИР MS EXCEL - Гость.xls

Вход

Регистрация

Напомнить пароль

 

= Мир MS Excel/Автоматическая вставка картинки из папки по артикулу V2.0 - Мир MS Excel

Регистрация · Логин: · Пароль: · · Забыли пароль?
  • Страница 1 из 1
  • 1
Модератор форума: _Boroda_, Manyasha, SLAVICK, китин  
Мир MS Excel » Вопросы и решения » Вопросы по Excel » Автоматическая вставка картинки из папки по артикулу V2.0 (Формулы/Formulas)
Автоматическая вставка картинки из папки по артикулу V2.0
Disney- Дата: Четверг, 09.04.2020, 16:35 | Сообщение № 1
Группа: Пользователи
Ранг: Прохожий
Сообщений: 2
Репутация: 0 ±
Замечаний: 0% ±

Excel 2019
Добрый день.
Формируется из программы файл «коммерческое предложение» . Имеется сетевая папка в которой лежат картинки с именем типа «Артикул.jpg» Необходимо вставить картинки в соответствующую ячейку (в примере столбец “B”). Количество строк, естественно, варьируется.
Нашел пример, но в нем удаляются повторы изображений. http://www.excelworld.ru/forum/2-42423-1

Подскажите пожалуйста, как можно сделать, чтобы повторы изображений с одинаковым наименованием артикула не удалялись.
И как можно изменить размер изображения?
К сообщению приложен файл: Img.rar(54.5 Kb)
 
Ответить
СообщениеДобрый день.
Формируется из программы файл «коммерческое предложение» . Имеется сетевая папка в которой лежат картинки с именем типа «Артикул.jpg» Необходимо вставить картинки в соответствующую ячейку (в примере столбец “B”). Количество строк, естественно, варьируется.
Нашел пример, но в нем удаляются повторы изображений. http://www.excelworld.ru/forum/2-42423-1

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

Автор - Disney-
Дата добавления - 09.04.2020 в 16:35
krosav4ig Дата: Четверг, 09.04.2020, 22:22 | Сообщение № 2
Группа: Друзья
Ранг: Старожил
Сообщений: 2323
Репутация: 976 ±
Замечаний: 0% ±

Excel 2007,2010,2013
Здравствуйте
[vba]
Код
Public Sub InsPict()
    Dim arr, fldPath$, art$, fName$, i&, r0, lrow&, oDic As Object, IShape As Shape, Zm
    Dim v As Variant
    Set oDic = CreateObject("Scripting.Dictionary")
    r0 = 4
    lrow = Cells(Rows.Count, 3).End(xlUp).Row
    arr = Cells(r0, 3).Resize(lrow - r0 + 1).Value
    For i = 1 To UBound(arr)
        v = oDic(arr(i, 1))
        If IsEmpty(v) Then
            oDic(arr(i, 1)) = Array(i + r0 - 1)
        Else
            ReDim Preserve v(UBound(v) + 1)
            v(UBound(v)) = i + r0 - 1
            oDic(arr(i, 1)) = v
        End If
    Next i
    For Each IShape In ActiveSheet.Shapes
        If IShape.Type <> 8 Then IShape.Delete
    Next
    fldPath = ThisWorkbook.Path & "\images\"    'путь к папке с изображениями
    Application.ScreenUpdating = False
    fName = Dir(fldPath & "*.jpg")
    Do While fName <> ""
        art = Split(fName, ".")(0)
        If oDic.Exists(art) Then
            For Each v In oDic(art)
                With Cells(v, 2)
                    Set IShape = ActiveSheet.Shapes.AddPicture(fldPath & fName, False, True, .Left + 1, .Top + 1, -1, -1)
                    Zm = WorksheetFunction.Min(.Width / IShape.Width, .Height / IShape.Height)
                    IShape.Height = IShape.Height * Zm - 2
                End With
            Next
        End If
        fName = Dir
    Loop
    Application.ScreenUpdating = True
End Sub
[/vba]


email:krosav4ig26@gmail.com WMR R207627035142 WMZ Z821145374535 ЯД 410012026478460

Сообщение отредактировал krosav4ig - Четверг, 09.04.2020, 22:23
 
Ответить
СообщениеЗдравствуйте
[vba]
Код
Public Sub InsPict()
    Dim arr, fldPath$, art$, fName$, i&, r0, lrow&, oDic As Object, IShape As Shape, Zm
    Dim v As Variant
    Set oDic = CreateObject("Scripting.Dictionary")
    r0 = 4
    lrow = Cells(Rows.Count, 3).End(xlUp).Row
    arr = Cells(r0, 3).Resize(lrow - r0 + 1).Value
    For i = 1 To UBound(arr)
        v = oDic(arr(i, 1))
        If IsEmpty(v) Then
            oDic(arr(i, 1)) = Array(i + r0 - 1)
        Else
            ReDim Preserve v(UBound(v) + 1)
            v(UBound(v)) = i + r0 - 1
            oDic(arr(i, 1)) = v
        End If
    Next i
    For Each IShape In ActiveSheet.Shapes
        If IShape.Type <> 8 Then IShape.Delete
    Next
    fldPath = ThisWorkbook.Path & "\images\"    'путь к папке с изображениями
    Application.ScreenUpdating = False
    fName = Dir(fldPath & "*.jpg")
    Do While fName <> ""
        art = Split(fName, ".")(0)
        If oDic.Exists(art) Then
            For Each v In oDic(art)
                With Cells(v, 2)
                    Set IShape = ActiveSheet.Shapes.AddPicture(fldPath & fName, False, True, .Left + 1, .Top + 1, -1, -1)
                    Zm = WorksheetFunction.Min(.Width / IShape.Width, .Height / IShape.Height)
                    IShape.Height = IShape.Height * Zm - 2
                End With
            Next
        End If
        fName = Dir
    Loop
    Application.ScreenUpdating = True
End Sub
[/vba]

Автор - krosav4ig
Дата добавления - 09.04.2020 в 22:22
Disney- Дата: Пятница, 10.04.2020, 10:13 | Сообщение № 3
Группа: Пользователи
Ранг: Прохожий
Сообщений: 2
Репутация: 0 ±
Замечаний: 0% ±

Excel 2019
krosav4ig, спасибо большое.
Подскажите еще пожалуйста, как можно править размер изображений и столбец в который вставляется картинка
 
Ответить
Сообщениеkrosav4ig, спасибо большое.
Подскажите еще пожалуйста, как можно править размер изображений и столбец в который вставляется картинка

Автор - Disney-
Дата добавления - 10.04.2020 в 10:13
Мир MS Excel » Вопросы и решения » Вопросы по Excel » Автоматическая вставка картинки из папки по артикулу V2.0 (Формулы/Formulas)
  • Страница 1 из 1
  • 1
Поиск:

jooble Яндекс цитирования
© 2010-2020 · Дизайн: MichaelCH · Хостинг от uCoz · При использовании материалов сайта, ссылка на www.excelworld.ru обязательна!