Оптимизировать код

[strannick]

Добрый день, уважаемые форумчане!
Помогите оптимизировать код:

Sub АвтоСчет()
    Application.ScreenUpdating = False
Dim sh As Worksheet, sh1 As Worksheet
Dim iLastRow As Long
    Set sh = Sheets("База заказов")
    Set sh1 = Sheets("Электронный счет")
    iLastRow = sh.Cells(Rows.Count, 6).End(xlUp).row
Application.ScreenUpdating = False
On Error Resume Next
For i = 4 To 500
If sh.Cells(i, 6) = "" Then Exit Sub
If sh.Cells(i, 1).Value >= sh.Cells(2, 1).Value Then    
ElseIf sh.Cells(i, 1).Value = sh.Cells(2, 1).Value And sh.Cells(i + 1, 1).Value <> sh.Cells(2, 1).Value Then
    sh.Cells(i, 2) = 1
    sh.Cells(i, 5) = "отправлен"
    sh.Cells(i, 24) = Now()
    sh1.Cells(11, 1) = sh.Cells(i, 1)
    sh1.Cells(11, 2) = 1
    Call Счет
    Call SendmailTheBat
    Call ПереносПокупателя
    sh.Cells(2, 1).Value = sh.Cells(2, 1).Value + 1   
ElseIf sh.Cells(i, 1).Value = sh.Cells(2, 1).Value And sh.Cells(i + 1, 1).Value = sh.Cells(2, 1).Value And sh.Cells(i + 2, 1).Value <> sh.Cells(2, 1).Value Then
    sh.Cells(i + 1, 2) = 2
    sh.Cells(i, 5) = "отправлен"
    sh.Cells(i + 1, 5) = "отправлен"
    sh.Cells(i, 24) = Now()
    sh.Cells(i + 1, 24) = Now()
    sh1.Cells(11, 1) = sh.Cells(i + 1, 1)
    sh1.Cells(11, 2) = 2
    Call Счет
    Call SendmailTheBat
    Call ПереносПокупателя
    sh.Cells(2, 1).Value = sh.Cells(2, 1).Value + 1    
ElseIf sh.Cells(i, 1).Value = sh.Cells(2, 1).Value And sh.Cells(i + 1, 1).Value = sh.Cells(2, 1).Value And sh.Cells(i + 2, 1).Value = sh.Cells(2, 1).Value And sh.Cells(i + 3, 1).Value <> sh.Cells(2, 1).Value Then
    sh.Cells(i + 2, 2) = 3
    sh.Cells(i, 5) = "отправлен"
    sh.Cells(i + 1, 5) = "отправлен"
    sh.Cells(i + 2, 5) = "отправлен"
    sh.Cells(i, 24) = Now()
    sh.Cells(i + 1, 24) = Now()
    sh.Cells(i + 2, 24) = Now()
    sh1.Cells(11, 2) = sh.Cells(i + 2, 1)
    sh1.Cells(11, 2) = 3
    Call Счет
    Call SendmailTheBat
    Call ПереносПокупателя
    sh.Cells(2, 1).Value = sh.Cells(2, 1).Value + 1    
'и еще три аналогичных блока (проверка на 4, 5, 6) удалил отсюда потому как длинное сообщение получается
End If
Next
    Application.ScreenUpdating = True    
End Sub

Файл с таблицей во вложении. В таблицу импортируются данные в диапазон F:V. В столбце А автоматом новым данным присваиваются номера счетов. В ячейке А2 макрос проставляет очередной номер счета, с которого надо формировать новые счета. Товаров в счете не бывает больше 6 (6 блоков проверки). По проверке проставляются нужные данные и вызываются макросы формирования счета, отправки по почте и переноса данных. Все эти макросы работают быстро. А сама вот эта приведенная процедура очень медленно.
И еще. Так как обработка идет долго думал присовокупить какой-нибудь прогрессбар самого простого вида. Вот у EducatedFool на сайте есть разные варианты. В файл вложил самый на мой взгляд простой. Но как его привязать к данной операции - ума не приложу.
Заранее спасибо!!!

[Step_UA]

Доброго. При импорте в столбцы F:V данные перезаписываются или добавляются к ранее существовавщим?

[strannick]

Сообщение от Step_UA

Доброго. При импорте в столбцы F:V данные перезаписываются или добавляются к ранее существовавщим?

Добавляются к ранее существующим. Таблица расширяется вниз. В столбце А появляются новые номера, которые равны и больше того номера, который макрос записал в ячейку А2 при предыдущей обработке. Вот их-то и определяет этот макрос, обрабатывает и вызывает другие макросы. Новый данные импортируются другим макросом, который срабатывает по таймеру каждые 30 мин. Он же и вызывает этот макрос.

[Step_UA]

Если правильно понял задачу

Sub АвтоСчет()
Dim sh As Worksheet, sh1 As Worksheet
Dim iLastRow As Long, i As Long, j As Long, Num As Long
    Set sh = Sheets("База заказов")
    Set sh1 = Sheets("Электронный счет")
    Application.ScreenUpdating = False
    On Error Resume Next
    iLastRow = sh.Cells(Rows.Count, 6).End(xlUp).row
    i = sh.Cells(2, 2).Value ' первая строка при следующей обработке
    While i <= iLastRow
        Num = sh.Cells(i, 1).Value
        j = 1: sh1.Cells(11, 1) = Num
        'Cells(2, 1).Value = Num ' текущий счет
        While sh.Cells(i + j, 1).Value = Num: j = j + 1: Wend
        sh1.Cells(11, 2) = j
        sh.Cells(i, 2).Resize(j).Value = j
        sh.Cells(i, 5).Resize(j).Value = "отправлен"
        sh.Cells(i, 24).Resize(j).Value = Now
        Call Счет
        Call SendmailTheBat
        Call ПереносПокупателя
        'Application.Wait Now() + TimeValue("00:00:05")
        i = i + j
      Wend
    Cells(2, 2).Value = i
    Application.ScreenUpdating = True
    Set sh = Nothing: Set sh1 = Nothing
End Sub

В ячейке B2 хранится номер строки с которой происходит обработка при последующем вызове - первоначально установите равной 4
Если номер счета (A1) используется при формировании и отправке счета - раскоментируйте работу с ячейкой 2,1.

[strannick]

Да, все правильно. Значительно быстрее стало. На порядок. Уж не знаю, можно ли сделать еще быстрее. Спасибо огромное!!!
Вопрос по прессбару остается в силе. К чему его можно привязать? К Num?

[Step_UA]

привязывайте к Num

sh.Cells(2, 2).Value ' минимальное значение Num
sh.cells(iLastRow,1).value ' максимальное значение

[Hugo121]

Подозреваю, что можно сделать намного быстрее, т.е. очень быстрее - что прогрессбар будет занимать 90% времени, т.е. будет не нужен.
Но только расскажите словами, что нужно сделать в приложенном файле - а то на этом кастрированном варианте код писать (и вникать в детали) не получится.

[strannick]

На листе Пояснения прописал что и как. По поводу прогрессбара решил не заморачиваться. Думаю

Application.StatusBar  = "Обрабатывается счет №" & Num

этого будет достаточно. Только прописать его где именно?

[Hugo121]

Всё словами объясните.
Ну а пока основной тормоз - это Application.Wait Now() + TimeValue("00:00:05"), ну и зачем по сто раз перезаписывать уже перезаписанное?

Ну и может есть смысл идти снизу вверх, пока номер не сравняется с критерием?
Зачем перебирать уже ранее проверенные номера?
Или писать макросом вместе с номером и номер первой обрабатываемой следующий раз строки - чтоб зря не работать.

[strannick]

Сообщение от Hugo121

Ну а пока основной тормоз - это Application.Wait Now() + TimeValue("00:00:05")

Так этот тормоз это Application.Wait Now() + TimeValue("00:00:05") у меня отключен.

Сообщение от Hugo121

Зачем перебирать уже ранее проверенные номера?
Или писать макросом вместе с номером и номер первой обрабатываемой следующий раз строки - чтоб зря не работать.

Это-то я понимал, но как реализовать не дотумкал. А Step_UA как раз и пошел по этому пути:

i = sh.Cells(2, 2).Value ' первая строка при следующей обработки

в ячейку В2 сохраняется номер строки для последующей обработки.

Вопрос о статусбаре снимается, уже прописал где надо.