Запись в файл Excel с проблемами скорости VB6

У меня есть код, который открывает файл excel, используемый для сопоставления данных. Затем открывает файл транзакций и добавляет столбцы в файл на основе данных сопоставления. Он работает, однако у меня проблемы со скоростью, он работает медленно. Если я нажимаю и удерживаю полосу прокрутки в Excel, она ускоряется, но когда я отпускаю кнопку мыши, она снова замедляется, мысли?

Dim MapLocation As String
Dim MapHeader As Integer
Dim MapColumnLegacy As Integer
Dim MapColumnFE As Integer
Dim MapColumnClass As Integer
Dim MapColumnProject As Integer
Dim MapColumnTcode1 As Integer
Dim MapColumnTcode2 As Integer
Dim MapColumnTcode3 As Integer
Dim MapColumnTcode4 As Integer
Dim MapColumnTcode5 As Integer
'Dim MapLines As Integer

Dim TransLocation As String
Dim TransHeader As Integer
Dim TransLines As Integer
Dim TransColumnLegacy As Integer
Dim ConvertSheet As Integer

Dim Xl As New Excel.Application
Dim Xlsheet As Excel.Worksheet
Dim Xlwbook As Excel.Workbook


Dim OldAcctID() As String
Dim NewAcctID() As String
Dim NewProjID() As String
Dim NewClassID() As String
Dim NewTcode1ID() As String
Dim NewTcode2ID() As String
Dim NewTcode3ID() As String
Dim NewTcode4ID() As String
Dim NewTcode5ID() As String

Dim I As Integer
Dim J As Integer

Dim Sheet As Object

Sub AcctConv_Main()
 Call Cleanup
 Call File_Access
 Call OpenExcelfile
End Sub

Sub Cleanup()
 ReDim OldAcctID(TransLines) As String
 ReDim NewAcctID(TransLines) As String
 ReDim NewProjID(TransLines) As String
 ReDim NewClassID(TransLines) As String
 ReDim NewTcode1ID(TransLines) As String
 ReDim NewTcode2ID(TransLines) As String
 ReDim NewTcode3ID(TransLines) As String
 ReDim NewTcode4ID(TransLines) As String
 ReDim NewTcode5ID(TransLines) As String
 I = 1
 For I = 1 To TransLines
    OldAcctID(I) = ""
    NewAcctID(I) = ""
 Next I

End Sub

Sub File_Access()
' Open Account Mapping and input the data from
' columns which contain the old and
' new data for the account mappings
'
If MapHeader = 0 Then
I = 1
Else: I = 2
End If
Xl.Workbooks.Open MapLocation
Xl.ActiveWorkbook.RunAutoMacros xlAutoOpen
For I = 1 To TransLines
    OldAcctID(I) = Cells(I, MapColumnLegacy)
    NewAcctID(I) = Cells(I, MapColumnFE)
    If Config_Form.MapProject_Check.Value = 1 Then
    NewProjID(I) = Cells(I, MapColumnProject)
    End If
    If Config_Form.MapClass_Check.Value = 1 Then
    NewClassID(I) = Cells(I, MapColumnClass)
    End If
    If Config_Form.MapTcode1_Check.Value = 1 Then
    NewTcode1ID(I) = Cells(I, MapColumnTcode1)
    End If
    If Config_Form.MapTcode2_Check.Value = 1 Then
    NewTcode2ID(I) = Cells(I, MapColumnTcode2)
    End If
    If Config_Form.MapTcode3_Check.Value = 1 Then
    NewTcode3ID(I) = Cells(I, MapColumnTcode3)
    End If
    If Config_Form.MapTcode4_Check.Value = 1 Then
    NewTcode4ID(I) = Cells(I, MapColumnTcode4)
    End If
    If Config_Form.MapTcode5_Check.Value = 1 Then
    NewTcode5ID(I) = Cells(I, MapColumnTcode5)
    End If
Next I
Xl.ActiveWorkbook.Close False
Xl.Quit

End Sub

Sub OpenExcelfile()

    Xl.Workbooks.Open (TransLocation)
    ActiveWorkbook.Sheets(ConvertSheet).Activate
    Xl.Visible = True
    'Opens transaction document to insert columns
    Call LegacyAttribute
     'Insert a new Column for Attribute and renames it, renames Legacy account header as Attribute Type
    Call InsertNewAccount
     'Insert a new Column for FE account and renames it
    Call InsertNewProject
    'Insert a new Column for Project and renames it
     Call InsertNewClass
    'Insert a new Column for Class and renames it
     Call InsertNewTcode1
    'Insert a new Column for Tcode1 and renames it
     Call InsertNewTcode2
    'Insert a new Column for Tcode2 and renames it
     Call InsertNewTcode3
    'Insert a new Column for Tcode3 and renames it
     Call InsertNewTcode4
    'Insert a new Column for Tcode4 and renames it
     Call InsertNewTcode5
    'Insert a new Column for Tcode5 and renames it
    Call PlugInNewAcctIDs
    'save the file
    Xl.ActiveWorkbook.Save
    'close the file
    Xl.ActiveWorkbook.Close
    Xl.Quit
    Convertwait_Form.Hide
    Unload Convertwait_Form
    MsgBox "Your Accounts Have Been Converted", vbExclamation, "Conversion Complete"
'get the next file

End Sub

Sub PlugInNewAcctIDs()
 ' Go back to the main XL document and
 ' plug in the new account numbers when a match
 ' to the old number is found in the first column
 '
 Convertwait_Form.Show

 BadCell = Cells(I, 2)
 I = 1
 J = 1
 For I = 1 To TransLines
 If (Cells(I, 1) = "") And (Cells(I + 1, 1) = "") And (Cells(I + 2, 1) = "")Then
    GoTo Continue
Else
        For J = 1 To TransLines
            If Cells(I, 1) = OldAcctID(J) Then
                Cells(I, 2) = "Legacy Account"
                Cells(I, 3) = NewAcctID(J)
            If Config_Form.MapProject_Check.Value = 1 Then
                Cells(I, 4) = NewProjID(J)
            End If
            If Config_Form.MapClass_Check.Value = 1 Then
                Cells(I, 5) = NewClassID(J)
            End If
            If Config_Form.MapTcode1_Check.Value = 1 Then
                Cells(I, 6) = NewTcode1ID(J)
            End If
            If Config_Form.MapTcode2_Check.Value = 1 Then
                Cells(I, 7) = NewTcode2ID(J)
            End If
            If Config_Form.MapTcode3_Check.Value = 1 Then
                Cells(I, 8) = NewTcode3ID(J)
            End If
            If Config_Form.MapTcode4_Check.Value = 1 Then
                Cells(I, 9) = NewTcode4ID(J)
            End If
            If Config_Form.MapTcode5_Check.Value = 1 Then
                Cells(I, 10) = NewTcode5ID(J)
            End If
            End If
            If Cells(I, 3) = "" Then
                Cells(I, 3) = "Missing Account Mapping"
            End If

        Next J
  End If
            If Cells(I, 3) = "Missing Account Mapping" Then
                Cells(I, 3).Interior.ColorIndex = 44
                Cells(I, 3).Font.Color = vbRed
            End If
  Next I

  Continue:

End Sub