Медленный код в Excel VBA на большом файле, как сделать это быстрее?

Question

У меня есть код, который мне нужно запускать ежемесячно на 500.000 строк базы данных Excel.Код просматривает 1 целую базу данных разных Owbers и разбивает ее на разные вкладки, создавая их, если они изначально не существуют.Я довольно новичок в кодировании и создании, и заставить его работать было большим успехом для меня, но требуется целая вечность, чтобы пройти всю электронную таблицу (5 минут / 10.000 записей - около 3 - 5 часов по всей электронной таблице).Кто-нибудь может взглянуть и, возможно, заставить его работать быстрее?Я не очень разбираюсь в массивах, но я думаю, что работа с ними может заставить его работать лучше.

Извините за плохое кодирование:

`

'Loop through spreadsheet and create new tabs if needed

Sub Copy_To_Tab()
Dim Main As Worksheet
Dim a, LR, LR2, LR3 As Integer
Dim Sht As String

Set Main = Sheets(1)

Application.ScreenUpdating = False

a = 2
LR = Main.Range("A" & Rows.Count).End(xlUp).Row

Do Until a > LR
ponownie:
        Sht = Main.Range("R" & a).Value
        If Sht = "" Then GoTo drugi:
        On Error Resume Next
        LR2 = Sheets(Sht).Range("A" & Rows.Count).End(xlUp).Row + 1
        If Err.Number = 9 Then GoTo stworz:
        Main.Range("A" & a & ":AB" & a).Copy Sheets(Sht).Range("A" & LR2)
drugi:
    If Main.Range("R" & a).Value <> Main.Range("S" & a).Value Then
ponownie2:
        Sht2 = Main.Range("S" & a).Value
        If Sht2 = "" Then GoTo nastepny:
        On Error Resume Next
        LR3 = Sheets(Sht2).Range("A" & Rows.Count).End(xlUp).Row + 1
        If Err.Number = 9 Then GoTo stworz2:
        Main.Range("A" & a & ":AB" & a).Copy Sheets(Sht2).Range("A" & LR3)
    End If
nastepny:

a = a + 1
Loop
Application.ScreenUpdating = True
MsgBox "Finished"
Exit Sub

stworz:
CreateSheet (Sht)
GoTo ponownie:

stworz2:
CreateSheet (Sht2)
GoTo ponownie2:

End Sub

'Create new worksheet and name it
Sub CreateSheet(Nazwa As String)
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets.Add(After:= _
             ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
    ws.Name = Nazwa
    Sheets(1).Range("A1:AZ1").Copy ws.Range("A1")
End Sub

`