You need to enable JavaScript to run this app.
优惠活动
大模型
产品
解决方案
定价
更多

VBA代码性能优化与结构改进咨询:ClientPrep子程序优化建议

VBA子程序ClientPrep性能优化与随机报错问题咨询

我编写的ClientPrep VBA子程序存在性能问题,偶尔还会随机报错,怀疑是代码结构设计不合理导致的。想请教以下几个优化相关的问题:

  • 使用With .Application替代直接调用Application.是否能提升效率?
  • 对于wbTarget.Worksheets这类重复调用的语句,有没有类似的优化方式?
  • 除此之外,还有哪些可以改进的方向或是推荐的优化措施?

以下是我的代码:

Sub ClientPrep()

    Dim wbTarget As Workbook
    Dim strPathBin As String
    Dim strSSPath As String
    Dim strTab As String
    Dim strInt As Integer
      
    'Application.DisplayAlerts = False
    Application.AskToUpdateLinks = False
    Application.AlertBeforeOverwriting = False
    Application.ScreenUpdating = False
    Application.CalculateBeforeSave = False
    Application.Calculation = -4135
    
    '''
    Sheets("Results").Activate
    WeekEndDate = Format(Application.WorksheetFunction.Max(Columns("F")), "mm-dd-yyyy")

    Sheets("Cover Page").Activate
    
    strPathBin = ""
    strSSPath = "C:\Users\administrator\GCP\GCP-AMS - Reporting\Weekly_Hours_Reports" & "_Client_Copy\" & WeekEndDate & "\"
    
    '::-- Set batch variables --::'
    Shell ("cmd.exe /C SETx ClientCopyBin " & "_Client_Copy\" & WeekEndDate & "\")
    Shell ("cmd.exe /C SETx WeekEndDate " & WeekEndDate)

    '::-- Create Archive Directory --::'
    If Dir(strSSPath, vbDirectory) = "" Then
        Shell ("cmd /c mkdir """ & strSSPath & """")
    End If

    '::-- Get Client Name --::'
    strString = Replace(ActiveWorkbook.Worksheets("Cover Page").Range("C2"), " ", "_")
    strName = WeekEndDate & "_" & strString & "_Hours_Report.xlsm"

    '::-- Remove Worbook if Exist --::'
    If Dir(strSSPath & strName) <> "" Then
        Kill strSSPath & strName
    End If

    Application.Wait (Now + TimeValue("0:00:02"))
    
    '::-- Make Workbook Copy --::'
    ActiveWorkbook.SaveCopyAs strSSPath & strName
    
    '::-- Open Client Workbook --::'
    Application.DisplayAlerts = False
           
    Set wbTarget = Workbooks.Open(strSSPath & strName)
    
    'Application.DisplayAlerts = True
    
    '::-- Hide Period Tabs if no data exists --::'
    Dim i As Integer
    For i = 1 To 12
    
        strTab = "P" & i
        
        Sheets(strTab).Cells.Copy
        Sheets(strTab).Cells.PasteSpecial Paste:=xlPasteValues
        Application.CutCopyMode = False
        
        If i > m Then wbTarget.Worksheets(strTab).Visible = xlSheetHidden
        
        wbTarget.Worksheets(strTab).Range("B:B").EntireColumn.AutoFit
        Sheets(strTab).Activate
        ActiveSheet.Cells(1, 1).Select
    Next
             
    For i = 1 To 4
        
        strTab = "Q" & i
        
        Sheets(strTab).Cells.Copy
        Sheets(strTab).Cells.PasteSpecial Paste:=xlPasteValues
        Application.CutCopyMode = False
                
        If i > q Then wbTarget.Worksheets(strTab).Visible = xlSheetHidden
        
        wbTarget.Worksheets(strTab).Range("B:B").EntireColumn.AutoFit
        Sheets(strTab).Activate
        ActiveSheet.Cells(1, 1).Select
        
    Next i
    
    Sheets("Overage_Tracker").Cells.Copy
    Sheets("Overage_Tracker").Cells.PasteSpecial Paste:=xlPasteValues
    Application.CutCopyMode = False
    ActiveSheet.Cells(1, 1).Select
    
    '''Exception

    If strString = "Victra" Then
            With Sheets("Results")
            LastP = .Range("B" & Rows.Count).End(xlUp).Row
            Application.ScreenUpdating = False
            For r = LastP To 2 Step -1
                If .Cells(r, "B") <> "Victra - Managed Services" Then .Cells(r, "B").EntireRow.Delete
            Next r
        End With
    Else
    
        '::-- Clear Results Tab --::'
        wbTarget.Worksheets("Results").Cells.Clear
    End If
   
    '::-- Hide Sheets --::'
    On Error Resume Next
    wbTarget.Worksheets("Contract").Visible = xlSheetHidden
    wbTarget.Worksheets("Results").Visible = xlSheetHidden
    wbTarget.Worksheets("Overage_Tracker").Visible = xlSheetHidden
    wbTarget.Worksheets("Instructions").Visible = xlSheetHidden
    wbTarget.Worksheets("Task").Visible = xlSheetHidden
    wbTarget.Worksheets("Rate_Card").Visible = xlSheetHidden
    wbTarget.Worksheets("Non-Standard_Tracker").Visible = xlSheetHidden
    On Error GoTo 0
    
    wbTarget.Worksheets("Cover Page").Activate

    wbTarget.SaveAs strSSPath & strName, AccessMode:=xlExclusive, ConflictResolution:=xlLocalSessionChanges
    'wbTarget.Save
    wbTarget.Close

    Set wbTarget = Nothing
    ActiveWorkbook.Worksheets("Cover Page").Activate
    
    
End Sub

内容的提问来源于stack exchange,提问作者chrtak

相关产品推荐
方舟 Agent Plan

超全模态模型 × Harness 升级,最新支持 Deepseek-V4.1-Flash、GLM-5.3 系列、Doubao-Seedream-5.0-pro、Kimi-K3 (部分), 限时 9.9 元起

最近更新时间:2026.06.14 05:44:55