ускорение удаления рандомно выбранных строк

Старая форма входа

Страница 1 из 1 1
Модератор форума: китин, _Boroda_

Мир MS Excel » Вопросы и решения » Вопросы по VBA » ускорение удаления рандомно выбранных строк (Макросы/Sub)

rosko

Дата: Четверг, 26.01.2017, 00:11 | Сообщение № 1

Группа: Пользователи

Ранг: Участник

Сообщений: 58

Репутация: 0 ±

Замечаний: 0% ±

Excel 2010

Добрый вечер, Форумчане!
Столкнулся с проблемой, прошу Вашей помощи!
Есть файл с около 340 тыс. строк. Необходимо случайным образом примерно 40 тыс. строк выбрать и оставить, а остальные удалить.
В прикрепленном файле, собственно, это и осуществляется. Проблема в том, что на реальном файле эксель виснет (к неудаче рабочий комп
celerone & 2Gb оперативной памяти), в итоге через 40 минут отработки закладка программы на панели задач начинает дергаться будто
предвещая конец, но нет. Пробовал ускорить: известно точное количество изначальных строк и столбцов, вставлял числами вместо поиска последних.
В итоге уже через 5 минут закладка программы на панели задач начинает дергаться, и только... Можно ли как-то ускорить данный макрос, подскажите, пожалуйста?

[vba]

Код

Sub delete_rand()

ScreenUpdating = False
Dim last_row As Long, last_col As Long

ThisWorkbook.Worksheets(1).Activate
last_row = Cells(Rows.Count, 1).End(xlUp).Row
last_col = Cells(1, Columns.Count).End(xlToLeft).Column

For i = 1 To last_row
    Cells(i, last_col + 1).Value = Int((17 - 1 + 1) * Rnd + 1)
Next

For j = Cells(Rows.Count, 1).End(xlUp).Row To 1 Step -1
    If Not Cells(j, last_col + 1) = 7 Or Cells(j, last_col + 1) = 11 Then
    Cells(j, last_col + 1).EntireRow.Delete
    End If
Next

ScreenUpdating = True
End Sub

[/vba]

К сообщению приложен файл: example.xlsx (10.3 Kb)

Сообщение отредактировал rosko - Четверг, 26.01.2017, 00:20

Ответить

bmv98rus

Дата: Четверг, 26.01.2017, 00:42 | Сообщение № 2

Группа: Друзья

Ранг: Участник клуба

Сообщений: 4107

Репутация: 768 ±

Замечаний: 0% ±

Excel 2013/2016

rosko,

Попробуйте отключить все перед началом обработки и включит после.
[vba]

Код

With application
.Calculation = xlCalculationManual
.EnableEvents = False
.ScreenUpdating = False
end with
.........

With application
.Calculation = xlCalculationAutomatic
.EnableEvents = True
.ScreenUpdating = True
end with

[/vba]

хотя скорее всего упрется в производительность ПК и код. Код вижу далее уже подправили.

~~Замечательный~~ Временно просто медведь ~~, процентов на 20~~.

Сообщение отредактировал bmv98rus - Четверг, 26.01.2017, 01:14

Ответить

Саня

Дата: Четверг, 26.01.2017, 00:57 | Сообщение № 3

Группа: Друзья

Ранг: Ветеран

Сообщений: 1068

Репутация: 560 ±

Замечаний: 0% ±

XL 2016

этот кусок:
[vba]

Код

For j = Cells(Rows.Count, 1).End(xlUp).Row To 1 Step -1
    If Not Cells(j, last_col + 1) = 7 Or Cells(j, last_col + 1) = 11 Then
    Cells(j, last_col + 1).EntireRow.Delete
    End If
Next

[/vba]

меняем на это:
[vba]

Код

dim rngGarb as range
For j = Cells(Rows.Count, 1).End(xlUp).Row To 1 Step -1
    If Not Cells(j, last_col + 1) = 7 Or Cells(j, last_col + 1) = 11 Then
    if rngGarb is nothing then
        set rngGarb = range("a" & j)
    else
        set rngGarb = union(range("a" & j), rngGarb)
    end if
    '''    Cells(j, last_col + 1).EntireRow.Delete
    End If
Next

if not rngGarb is nothing then
    rngGarb.EntireRow.Delete
end if

[/vba]

этот прием должен многократно сократить время выполнения

Сообщение отредактировал Саня - Четверг, 26.01.2017, 00:58

Ответить

_Boroda_

Дата: Четверг, 26.01.2017, 02:01 | Сообщение № 4

Группа: Модераторы

Ранг: Местный житель

Сообщений: 16675

Репутация: 6481 ±

Замечаний: 0% ±

2003; 2007; 2010; 2013 RUS

Саня, супер!
Все равно правда тормозит на больших объемах. Юнион - зараза та еще.
Вот откопал от ZVI предполагаемое ускорение и ссылку (на 4 поста выше)
http://www.planetaexcel.ru/forum....ge89799

rosko, вот здесь Вы пишете что-то странное (вернее, избыточное условие)

Цитата rosko, 26.01.2017 в 00:11, в сообщении № 1 ()

If Not Cells(j, last_col + 1) = 7 Or Cells(j, last_col + 1) = 11 Then

В переводе на русский - удаляем, если ячейка не равна 7 или если ячейка равна 11. Но если ячейка не равна 7, то нам уже все равно, равна ли она 11, мы в любом случае ее удаляем. Возможно, Вы хотели вот так (оставляем 7 и 11)?
[vba]

Код

If Not Cells(j, last_col + 1) = 7 And Not Cells(j, last_col + 1) = 11 Then

[/vba]
[vba]

Код

If Cells(j, last_col + 1) <> 7 And Cells(j, last_col + 1) <> 11 Then

[/vba]
Как раз 340000 / 40000 = 17 / 2

Скажи мне, кудесник, любимец ба’гов...
Платная помощь:
Boroda_Excel@mail.ru
Яндекс-деньги: 41001632713405 | Webmoney: R289877159277; Z102172301748; E177867141995

Ответить

anvg

Дата: Четверг, 26.01.2017, 07:11 | Сообщение № 5

Группа: Друзья

Ранг: Ветеран

Сообщений: 581

Репутация: 271 ±

Замечаний: 0% ±

2016, 365

Доброе время суток.
Как мне кажется - лобовое решение не будет быстрым. Проще через вспомогательный массив признаков с последующей сортировкой строк (Excel использует устойчивую сортировку) по нему и последующим удалением.

Успехов.

Ответить

СообщениеДоброе время суток.
Как мне кажется - лобовое решение не будет быстрым. Проще через вспомогательный массив признаков с последующей сортировкой строк (Excel использует устойчивую сортировку) по нему и последующим удалением.

Успехов.

Автор - anvg
Дата добавления - 26.01.2017 в 07:11

bmv98rus

Дата: Четверг, 26.01.2017, 10:00 | Сообщение № 6

Группа: Друзья

Ранг: Участник клуба

Сообщений: 4107

Репутация: 768 ±

Замечаний: 0% ±

Excel 2013/2016

rosko,
А вы поясните задачу исходную.

Я взял 300к строк с даными , правда формулой добавил рандомное значение в доп столбец для простоты, а потом через MS Query
[vba]

Код

SELECT *
FROM `TransList$` `TransList$`
WHERE (`TransList$`.RND<>7 And `TransList$`.RND<>11)

[/vba]
10 сек не прошло на другом листе все без этих строк
Вариант 2. Advanced Filter. с копией в другое место. с условиями <>7 и <>11 . Аналогично секунды. Хотя тот же обьем скриптом обрабатывался ооооочеь долго.

Оба варианта можно через скрипт организовать.

~~Замечательный~~ Временно просто медведь ~~, процентов на 20~~.

Сообщение отредактировал bmv98rus - Четверг, 26.01.2017, 10:04

Ответить

rosko

Дата: Четверг, 26.01.2017, 10:55 | Сообщение № 7

Группа: Пользователи

Ранг: Участник

Сообщений: 58

Репутация: 0 ±

Замечаний: 0% ±

Excel 2010

bmv98rus, Саня, _Boroda_, спасибо Вам огромное! запустил, пока вот 52 минуты еще считает:)
anvg, сразу не заметил Ваш код, сейчас опробую на другом пк!

Ответить

rosko

Дата: Четверг, 26.01.2017, 11:23 | Сообщение № 8

Группа: Пользователи

Ранг: Участник

Сообщений: 58

Репутация: 0 ±

Замечаний: 0% ±

Excel 2010

anvg, космос! отработал (правда на другом пк) меньше чем за полминуты.
Единственно, я не понял как Вы отбираете строки (только понял, что Вы задаете долю, которую взять)

Ответить

Wasilich

Дата: Четверг, 26.01.2017, 13:04 | Сообщение № 9

Группа: Друзья

Ранг: Старожил

Сообщений: 1232

Репутация: 326 ±

Замечаний: 0% ±

2003

А интересно, сколько будет работать этот код
[vba]

Код

Sub delete_rand()
  Dim i&, x&, last_row&, last_col&
  Application.ScreenUpdating = False
  Dim last_row As Long, last_col As Long
  ThisWorkbook.Worksheets(1).Activate
  last_row = Cells(Rows.Count, 1).End(xlUp).Row
  last_col = Cells(1, Columns.Count).End(xlToLeft).Column
  For i = 2 To last_row
    x = Int((17 - 1 + 1) * Rnd + 1)
    If x <> 7 And x <> 11 Then Range(Cells(i, 1), Cells(i, last_col)).Clear
  Next
  Range(Cells(2, 1), Cells(last_row, last_col)).Sort Key1:=Range("A2"), Order1:=xlAscending, Header:=xlNo, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
  Application.ScreenUpdating = True
End Sub

[/vba]

Сообщение отредактировал Wasilich - Четверг, 26.01.2017, 13:18

Ответить

Мир MS Excel » Вопросы и решения » Вопросы по VBA » ускорение удаления рандомно выбранных строк (Макросы/Sub)

Страница 1 из 1
1