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
相关产品推荐
相关产品推荐

