Поиск  Пользователи  Правила 
Закрыть
Логин:
Пароль:
Забыли свой пароль?
Регистрация
Войти
 
Страницы: 1
RSS
Подтянуть картинки с одного листа на другой по определенному значению
 
Добрый вечер.

Безуспешно пытаюсь уже 2 неделю заставить правильно работать макрос.
Очень нужна Ваша помощь или совет.

Есть файл с двумя листами, где на первом БД:  артикул-цвет модели и картинка
На втором листе данные Артикул-цвет, к которым надо подтянуть картинки во 2й столбец из первого листа.
Для этого есть макрос в книге.

Проблема в том, что он показывает ошибку, в случае когда, например, 2 ячейка пустая или ячейки объединены.
А при использование On error resume next, вставляет дубликаты картинок.

Как изменить макрос, чтобы картинки подставлялись только единожды без повторений напротив каждого артикула.
Заранее благодарен
 
Del
Изменено: Sanja - 24 Фев 2017 01:25:25
Согласие есть продукт при полном непротивлении сторон.
 
Не понятен ответ.
Можно пояснить, пожалуйста
 
Цитата
andrey_me написал:
Не понятен ответ
Это не ответ )) Точнее, был ответ, но Sanja его удалил - Delete :)
Ошибочный, наверное.
 
andrey_me, день добрый автору и всем.
у меня точно такой же случай, необходимо с одного листа подтягивать картинки на другой лист. воспользовалась макросом из примера автора темы, но он работает через раз, постоянно выдает ошибки, подскажите пожалуйста. как его доработать?
спасибо
 
так что ли? просто проверку на пустую ячеку добавил..
Код
Sub ПодтянутьКартинки()
    Application.ScreenUpdating = False
    Dim iLastrow As Integer, i As Integer
    Dim iLastRow2 As Integer
    Dim s As Integer
    Dim sh1 As Worksheet, sh2 As Worksheet
    Set sh1 = Sheets("картинки")
    Set sh2 = Sheets("лист1")
    iLastrow = sh2.Cells(Rows.Count, 1).End(xlUp).Row
    iLastRow2 = sh1.Cells(Rows.Count, 1).End(xlUp).Row
    For i = 2 To iLastrow
    If sh2.Cells(i, 1).Value <> "" Then
        sh1.Range("a2:a" & iLastRow2).Find(what:=sh2.Cells(i, 1).Value, LookIn:=xlValues).Offset(0, 1).Copy
           sh2.Activate
        sh2.Cells(i, 2).Select
        ActiveSheet.Pictures.Paste(Link:=True).Select
    End If
    Next i
    Application.ScreenUpdating = True
End Sub
 
yozhik,здорово, спасибо!
Страницы: 1
Читают тему (гостей: 1)
Наверх