Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
Оптимизация макроса удаления строк
 
#1
10.09.2020 21:09:46

Добрый день уважаемые форумчане!

Ежемесячно на работе занимаюсь трансформацией файла выгруженного из SAP в формате xls, затем через кнопку UserForm сохраняется в xlsx (исходный файл xls - закрывается) в файле xlsx удаляются строки, столбцы, строки содержащие определенные слова, и создается шапка таблиц. Появилась идея данное дело автоматизировать для любого пользователя кому выпадет данная задача. файл на 150 тыс строк, выполнение макроса около 6-8 минут (на разных компьютерах).
Большая часть кода искалась на этом форуме, просторах интернета, и справке по VBA (так как в программировании не силен)

Прошу помощи в следующем вопросе:  

Как можно оптимизировать данный код, что бы сократить время выполнения макроса

(Исходный и конечный файлы таблиц а так же файл с UserForm с кодом прикладываю (файлы сократил до 1000 строк))

Заранее благодарен за помощь и за Ваше потраченное время

С Уважением, Алексей
 
 
 
#2
10.09.2020 21:29:37
ТС, попробуйте заменить вот эту строку (если у вас всегда столбец А заполнен). А то вдруг у вас UsedRange.Row равен количеству всех строк на листе (которых больше 1 млн) и тогда конечно у вас будет долгая работа макроса
Код
lastrow =  ActiveSheet.UsedRange.Row - 1 + ActiveSheet.UsedRange.Rows.Count

на вот эту

Код
lastrow = Cells(Rows.Count, "A").End(xlUp).Row
Изменено: New - 10.09.2020 21:30:30
 
 
 
#3
10.09.2020 21:30:25
Вить, у ТС сильно развито воображение. Насколько моего воображения хватает
Оптимизация макроса удаления строк
Алексей Лепихин, замените
Код
    For i = 0 To UBound(iText)
        Set iRange = Columns("A:K").Find(What:=iText(i), LookIn:=xlFormulas, Lookat:=xlWhole)
        If Not iRange Is Nothing Then
            Do
                iRange.EntireRow.Delete
                Set iRange = Columns("A:K").Find(What:=iText(i), _
                                                 LookIn:=xlFormulas, Lookat:=xlWhole)
            Loop Until iRange Is Nothing
        End If
    Next i

на
Код
    Dim ar, lr&
    lr = Cells.Find("*", , , , xlByRows, xlPrevious).Row
    ar = Range("A1:K" & lr).Value
    For k = UBound(ar) To 1 Step -1
        For kk = 1 To UBound(ar, 2)
            For i = 0 To UBound(iText)
                If ar(k, kk) = iText(i) Then
                    Rows(k).Delete
                    GoTo metka
                End If
            Next
        Next
metka:
    Next

И, до кучи... Несколько одноименных процедур в проекте, вероятно, не грех, но большое свинство.
PS код не тестил, но вроде ошибок нет, должно работать.
Изменено: RAN - 10.09.2020 21:33:38
 
 
 
#4
10.09.2020 22:15:23
Большое спасибо  за предложенные варианты, проверил, все работает, время сократилось до 3 минут
 
 
 
#5
10.09.2020 22:28:15
Еще пара советов
чем чаще встречается слово(а) в файле, тем ближе к началу массива они должны быть расположены
Код
iText = Array("  ЕдОборуд", "Название технического объекта", "ВидОбъекта", "PIPE A")    'список слов на удаление

Если большая часть значений находится в конце строки, имеет смысл вести просмотр с конца
Код
For kk = UBound(ar, 2) To 1 Step -1
 
 
 
Страницы: 1
Наверх