VBA Excel оптимизация кода

[Корабль]

Привет всем
Моя задача не очень сложная:
Есть два листа, на одном находятся все застрахованные водители по всем страховым полисам, на другом - полисы без повторений. И требуется для каждого полиса определить наихудшего водителя.
С этим я справилась.

Загвоздка в том, что этот макрос выполняется очень-очень долго, 8к полисов из 2го листа обрабатываются часов 5. А требуется обработать порядка 100к полисов. А водителей ну просто очень много
Но увы моих знаний ( а изучать VBA я начала недели 2-3 назад) не хватает на то, что бы оптимизировать код. Все попытки это сделать по различным туториалам были тщетны, выдавались ошибки и ничего не работало Т_Т

Поэтому нижайше прошу помощи по оптимизации и в принципе советов, как лучше работать в VBA

Вот сам код
он работает и делает все как мне нужно, просто безумно долго

Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
    ActiveSheet.DisplayPageBreaks = False
    Application.DisplayStatusBar = False
    Application.DisplayAlerts = False


Dim sh1 As String 'лист с водителями
Dim sh2 As String 'лист с полисами
Dim i As Long 
Dim J As Long 
Dim Rang As Single 'худший ранг
Dim q As Long 'запомнить водителя с худшим рангом

J = 2
sh1 = "водители" 
sh2 = "худшие водители"

Do Until Sheets(sh2).Cells(j 1) = 0 'перебор полисов sh2

i = J
Rang = 100
q = 0

Do Until Sheets(sh1).Cells(i, 1) = 0 'перебор полисов sh1
If Sheets(sh1).Cells(i, 1) = Sheets(sh2).Cells(J, 1) Then ‘ выбирает одинаковые полисы

If Sheets(sh2).Cells(J, 2) = 1 Then 'если 1 водитель не нужно перебирать
Sheets(sh2).Cells(J, 3) = Sheets(sh1).Cells(i, 3)
Sheets(sh2).Cells(J, 4) = Sheets(sh1).Cells(i, 4)
Sheets(sh2).Cells(J, 5) = Sheets(sh1).Cells(i, 5)
Sheets(sh2).Cells(J, 6) = Sheets(sh1).Cells(i, 6)
Sheets(sh2).Cells(J, 7) = Sheets(sh1).Cells(i, 7)
Sheets(sh2).Cells(J, 8) = Sheets(sh1).Cells(i, 8)
Sheets(sh2).Cells(J, 9) = Sheets(sh1).Cells(i, 9)
GoTo 1
End If
‘отбирается особая группа
If Sheets(sh1).Cells(i, 9) = "есть" Then 
Sheets(sh2).Cells(J, 3) = “мультидрайв”
Sheets(sh2).Cells(J, 4) = “мультидрайв”
Sheets(sh2).Cells(J, 5) = “мультидрайв”
Sheets(sh2).Cells(J, 6) = “мультидрайв”
Sheets(sh2).Cells(J, 7) = “мультидрайв”
Sheets(sh2).Cells(J, 8) = “мультидрайв”
Sheets(sh2).Cells(J, 9) = “мультидрайв”
GoTo 1
End If

If Sheets(sh1).Cells(i, 8) < Rang then ' определение наименьшего ранга
if Sheets(sh1).Cells(i, 8) <> 0 Then ' проверка есть ли ранг вообще
Rang = Sheets(sh1).Cells(i, 8)
q = i
end if

ElseIf Sheets(sh1).Cells(i, 8) = Rang Then ' шовинизм
    If Sheets(sh1).Cells(i, 4) = "Ж" Then  ‘ да да, считается, что женщины водят хуже
    q = i
    End If
End If
End If
    

i = i + 1
Loop

If q <> 0 Then

Sheets(sh2).Cells(J, 3) = Sheets(sh1).Cells(q, 3)
Sheets(sh2).Cells(J, 4) = Sheets(sh1).Cells(q, 4)
Sheets(sh2).Cells(J, 5) = Sheets(sh1).Cells(q, 5)
Sheets(sh2).Cells(J, 6) = Sheets(sh1).Cells(q, 6)
Sheets(sh2).Cells(J, 7) = Sheets(sh1).Cells(q, 7)
Sheets(sh2).Cells(J, 8) = Sheets(sh1).Cells(q, 8)
Sheets(sh2).Cells(J, 9) = Sheets(sh1).Cells(q, 9)

End If
1:
J = J + 1
Loop


Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    ActiveSheet.DisplayPageBreaks = True
    Application.DisplayStatusBar = True
    Application.DisplayAlerts = True

End Sub

[DiemonStar]

Вы лучше приложите пример вашего исходного файла (с 50-100 записями). Без этого намного сложнее определять методы оптимизации.

[Корабль]

вот пример

убрала фамилии и поменяла номера полисов
конфиденциальность и все дела

кое где неверно группы определены, не обращайте внимания

[DiemonStar]

попробуйте такой макрос:

Sub FillBad()
  Dim Src As Worksheet, Dst As Worksheet, R As Range
  Set Src = Sheets("âîäèòåëè")
  Set Dst = Sheets("õóäøèå âîäèòåëè")
  Src.[A:I].Sort Key1:=Src.[A:A], Header:=xlYes
  Dst.[A:I].Sort Key1:=Dst.[A:A], Header:=xlYes
  Set R = Src.[A1]
  For I = 2 To Dst.Cells(Src.Rows.Count, 1).End(xlUp).Row
    Set R = Src.[A:A].Find(Dst.Cells(I, 1), R)
    If R Is Nothing Then
      Dst.Cells(I, 2) = 0
      Dst.Range(Dst.Cells(I, 3), Dst.Cells(I, 9)).Merge
      Dst.Cells(I, 3) = "Íåîïðåäåëåíî"
      Set R = Src.[A1]
    Else
      If R.Offset(, 8) = "åñòü" Then
        Dst.Cells(I, 2) = 0
        Dst.Range(Dst.Cells(I, 3), Dst.Cells(I, 9)) = "ìóëüòèäðàéâ"
      Else
        J = 0
        Bad = J
        MinRang = R.Offset(, 7)
        Do While R.Offset(J) = R
          If MinRang > R.Offset(J, 7) Then
            Bad = J
            MinRange = R.Offset(J, 7)
          ElseIf MinRang = R.Offset(J, 7) And R.Offset(J, 3) = "Æ" Then
            Bad = J
          End If
          J = J + 1
        Loop
        R.Offset(Bad, 2).Resize(1, 7).Copy Dst.Cells(I, 3)
      End If
    End If
  Next I
End Sub

[Корабль]

Спасибо
Все работает, ощутимо быстрее
только чуточку подправила, убрала объединения и нули в колонке кол-во водителей (так и не поняла, для чего это было)

чувствую, что пока буду разбирать этот код по символу - стану гуру вба
спасибо большое)

[DiemonStar]

только чуточку подправила, убрала объединения и нули в колонке кол-во водителей (так и не поняла, для чего это было)

Это обработка случая, когда на странице "плохих водителей" есть номер договора, отсутствующего среди всего списка водителей. Без этого макрос может вызвать ошибку.

Все работает, ощутимо быстрее

Если отключите обработку событий, обновление экрана и т.д., то скорость может еще немного прибавиться.

[Корабль]

оно сработало меньше, чем за 5 минут
о боги


просто по тому коду, макрос проставлял нули в тех случаях, когда номер полиса есть и там и там, но нет фио или еще чего то