Страницы: 1
RSS
Копирование с одного листа на другой по условию: упростить Select-Copy-Paste
 
Здравствуйте, уважаемые форумчане!
Хочу всего лишь попросить совета.
Не так давно знакома с VBA, написала макрос себе в помощь, для обновления информации в прайсе, путем сравнения данных с двух листов по конкретной клонке и последующими операциями расчета и копирования с одного листа на другой. Одними формулами все необходимое сделать не получилось. Все вроде работает как нужно, но очень долго считает (более 30 минут).
Есть ли какие-то способы повысить производительность? Следует сказать, что уже использованы следующие приемы и, соответственно, их отмена в конце макроса:
Код
Application.ScreenUpdating = False
Application.EnableEvents = False
If Workbooks.Count Then
      ActiveWorkbook.ActiveSheet.DisplayPageBreaks = False
  End If
в сравниваемых таблицах примерно по 3000 строк
Возможно, проблема в постоянном переключении между листами внутри цикла для копирования данных с одного листа на другой?
Код
 ElseIf Name1 Like Name2 Then
                 Worksheets("Лист1").Select
                 Range(Cells(x + 1, 6), Cells(x + 1, 6)).Copy
                 Worksheets("Export Products Sheet").Select
                 Range(Cells(i + 1, 6), Cells(i + 1, 6)).PasteSpecial
                 Cells(i + 1, 13) = "+"
                 Else:  
                 Worksheets("Лист1").Select
                 Range(Cells(x + 1, 1), Cells(x + 1, 57)).Copy
                 Worksheets("Export Products Sheet").Select
                 Range(Cells(LastRow + 1, 1), Cells(LastRow + 1, 57)).PasteSpecial
Возможно так и должно быть, т.к. объем данных достаточно большой и опреаций над ними производится много.
Прошу не высмеивать, это первое, что написано мной на VBA.
Заранее спасибо за ответы.
 
 
Конкретно по Вашему коду
Код
With Worksheets("Export Products Sheet")

.........................................

    ElseIf Name1 Like Name2 Then
        Worksheets("Лист1").Range(Cells(x + 1, 6), Cells(x + 1, 6)).Copy .Range(Cells(i + 1, 6), Cells(i + 1, 6))
        .Cells(i + 1, 13) = "+"
    Else
        Worksheets("Лист1").Range(Cells(x + 1, 1), Cells(x + 1, 57)).Copy .Range(Cells(LastRow + 1, 1), Cells(LastRow + 1, 57))
    End If
End With
SELECT И ACTIVATE - ЗАЧЕМ НУЖНЫ И НУЖНЫ ЛИ? - для начала
А в перспективе уходите от перебора ячеек к работе с массивами/коллекциями/словарями
Изменено: Sanja - 21.01.2017 23:29:51
Согласие есть продукт при полном непротивлении сторон
 
Sanja, спасибо большое, попробую сделать так.  
 
Sanja, в Вашем примере в строках 6 и 9 Cells будут браться не из указанного в коде листа, а из активного, или того, в чьём модуле расположен код.
 
Hugo, Ваша правда
Код
With Worksheets("Export Products Sheet")
Set Sh = Worksheets("Лист1")
 
.........................................
 
    ElseIf Name1 Like Name2 Then
        Sh.Range(Sh.Cells(x + 1, 6), Sh.Cells(x + 1, 6)).Copy .Range(.Cells(i + 1, 6), .Cells(i + 1, 6))
        .Cells(i + 1, 13) = "+"
    Else
        Sh.Range(Sh.Cells(x + 1, 1), Sh.Cells(x + 1, 57)).Copy .Range(.Cells(LastRow + 1, 1), .Cells(LastRow + 1, 57))
    End If
End With
Согласие есть продукт при полном непротивлении сторон
 
Думаю тут можно сократить, но честно говоря кажется тут хромает логика - если совпало ясно что копируем, а вот если вот конкретно сейчас не совпало - не рановато ли копировать диапазон? Может и поэтому тоже тормоза...
Код
    With Worksheets("Export Products Sheet")
        Set Sh = Worksheets("Лист1")

        '.........................................

    ElseIf Name1 Like Name2 Then
        Sh.Cells(x + 1, 6).Copy .Cells(i + 1, 6)
        .Cells(i + 1, 13) = "+"
    Else
        Sh.Range(Sh.Cells(x + 1, 1), Sh.Cells(x + 1, 57)).Copy .Cells(LastRow + 1, 1)
    End If
End With
 
Hugo, принцип такой: при совпадени обновляется цена и наличие (у Вас в коде стр. 7,8 ) при несовпадении в конец списка добавляется строка, как новинка (стр. 10).  
Изменено: Yanakan - 22.01.2017 16:28:26
 
Hugo, все, поняла, спасибо. Добавляется не то что нужно. Тут надо искать несовпадения в массиве, а не в конкретной ячейке, перебор для этого не подходит.
 
Yanakan!
Вы до сих пор не прикрепили Ваш файл и не описали свою проблему.
От Вас требуется показать исходную информацию и свою "хотелку".
Только после выполнения этих требований Вы получите профессиональную помощь.
Возможно, Ваш макрос "прикажет долго жить"!  :D
Страницы: 1
Наверх