Страницы: 1
RSS
Копировать-Вставить непустые строки
 

Здравствуйте,


Нужен макрос для быстрого копирования данных без пустых строк.
Вариант (Фильтр непустых строк->Копировать/Вставить->Очистка фильтра) в таблице из 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 секунд?

Буду рад любой помощи.
Спасибо.

 
Здравствуйте!
Как-то непонятно, что Вы хотите копировать - без пустых или уникальные? И файла-примера нет... Макрос какой-то непонятный...
По теме - скопировать и вставить непустые строки - попробуйте такой способ:
Код
Sub Без_пустых()
    Dim r&, nr&, arr
    arr = Range("A1:C" & Cells(Rows.Count, 1).End(xlUp).Row)
    ReDim b(1 To UBound(arr), 1 To 3)
For r = 1 To UBound(arr)
    If arr(r, 1) <> "" Then
       nr = nr + 1
       b(nr, 1) = arr(r, 1)
       b(nr, 2) = arr(r, 2)
       b(nr, 3) = arr(r, 3)
    End If
Next r
    Range("F1:H1").Resize(nr) = b
End Sub
Копируются данные из столбцов "A:C" без пустых ячеек в столбце "А", и вставляются в столбцы "F:H". У меня 500 тыс. строк обработались за три секунды, правда с SSD :) Пробуйте с Вашими 40 тыс :)
 
_Igor_61, Спасибо большое за макрос. Выяснилось что проблема в листе, куда копируются данные. Файл с полностью очищенным листом весит 300 КБ.
 
Если в темной комнате не видно кошки - это не значит, что ее нет :)
Или лист не очищен (не верь глазам своим), или есть другие листы
 
vikttur, Удалил styles.xml. Теперь абсолютно чистый.
Изменено: Шерзод Маткаримов - 23.01.2021 08:45:37
 
_Igor_61, можно и с одним массивом ☺
Код
Sub Без_пустых()
    Dim r&, nr&, arr
    arr = Range("A1:C" & Cells(Rows.Count, 1).End(xlUp).Row)
'    ReDim b(1 To UBound(arr), 1 To 3)
For r = 1 To UBound(arr)
    If arr(r, 1) <> "" Then
       nr = nr + 1
       arr(nr, 1) = arr(r, 1)
       arr(nr, 2) = arr(r, 2)
       arr(nr, 3) = arr(r, 3)
    End If
Next r
    Range("F1:H1").Resize(nr) = arr
End Sub
Всё сложное - не нужно. Всё нужное - просто /М. Т. Калашников/
 
Сейчас чтобы макрос работал нужно активировать лист откуда копируются данные

With Sheets("Лист1")
.Visible
.Select
Call Без_Пустых
End With

А можно вызвать макрос, из листа куда переносятся данные, или из любого листа
Например Данные из Лист1 в Лист2 работая на листе Лист3?

Спасибо.
 
Михаил Лебедев, вот так себе фига! Спасибо!!!  Я не профи в программировании, и на сайте потому, что очень нравится Excel. Что касается данного кода - несколько лет назад смотрел в интернете и в учебниках по VBA (конечно, тоже из интернета) - и везде было написано что для последующих действий исходный массив нужно переопределить через ReDim, иначе работать не будет. А оказывается массив и не причем, просто достаточно переменным нужное значение присвоить в нужных местах.... Так просто, что гениально!!! :)
Буду знать теперь, что не все, что в учебниках - правда (или правда, но не вся)   :)
ОГРОМНОЕ СПАСИБО!!!
P.S. Пока ходил в магазин понял, в каких случаях нужно переопределять, а когда и так можно :)
Изменено: _Igor_61 - 23.01.2021 17:10:23
 
Цитата
Шерзод Маткаримов написал:
А можно вызвать макрос, из листа куда переносятся данные, или из любого листа
А это уже совсем другая тема :) Создайте новую тему с новым вопросом
 
Цитата
_Igor_61 написал:
Пока ходил в магазин понял
Можно уточнить - для лучшего соображения в какие магазины нужно ходить? :)
 
vikttur, у меня рядом с домом  "Ярче" и "ОК", но на осознание решения повлиял не магазин, а прогулка на свежем воздухе :) Но... если что то... в "Ярче" и в "ОК" шампусик недорого :) А в "Пятерочке" уже давно ничего не покупаю, хотя она и в соседнем доме - у них даже хлеб и булочки несвежие и твердые всегда, не говоря о колбасе, сосисках и рыбе :)
 
off
Цитата
vikttur написал:
в какие магазины нужно ходить?
в правильные фитнес центры
По вопросам из тем форума, личку не читаю.
 
Доброй ночи,
Сейчас обнаружил что макрос неверно переносит цифры разделенные точкой.
Порядковые номера 1.1 1.2 1.3 переносятся как 1,1 1,2 1,3 т.е. вставляются запятые вместо точек. Можно ли исправить макрос?
Страницы: 1
Наверх