Здравствуйте,
Нужен макрос для быстрого копирования данных без пустых строк.
Вариант (Фильтр непустых строк->Копировать/Вставить->Очистка фильтра) в таблице из 40 тыс. строк занимает 13-15 секунд.
Вариант RemoveDuplicates тоже не лучше первого.
На этом форуме увидел макрос от Hugo, для переноса уникальных значений
Но и этот вариант работает медленнее варианта с фильтром.
Макрос выполняется за 4-5 сек., если отдельно запускать, А если вызвать внутри другого макроса (CALL CopyRange) выполняется 25 сек.
Макрос:
Код |
---|
Sub CopyRange()Dim FR As Long, LR As Long, A(), i&, II&, X As Byte, tmp$With Sheets("Лист1")FR = Application.Match(1, Range("AV1:AV100000"), 0)LR = .Cells(Rows.Count, 42).End(xlUp).RowA = Range(Cells(FR, 40), Cells(LR, 48))End With ReDim b(1 To UBound(A), 1 To 9) With CreateObject("Scripting.Dictionary") For i = 1 To UBound(A) tmp = A(i, 9) '9 Столбец ключ уникальных значений If Not .Exists(tmp) Then .Item(tmp) = vbNullString II = II + 1 For X = 1 To 3: b(II, X) = A(i, X): Next '1 To 3 Столбцы для переноса End If Next End WithSheets("Лист2").Range("AF14").Resize(II, 3) = b '3 Кол-во нужных столбцовEnd Sub |
Используя словарь или другие методы, можно ли добиться результата в 1-2 секунд?
Буду рад любой помощи.
Спасибо.