用VB6寫入Excel文件速度問題

Question

我有打開了用於映射數據的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 

Answer 1

這裏是如何做的是在意見建議......

您AcctConv_Main()程序改成這樣：

Sub AcctConv_Main() 
    Application.ScreenUpdating = False 
    Application.Calculation = xlCalculationManual 
     Call CleanUp 
     Call File_Access 
     Call OpenExcelfile 
    Application.Calculation = xlCalculationAutomatic 
    Application.ScreenUpdating = True 
End Sub