如何解决VBA脚本冻结问题

Question

我最近继承了一个VBA脚本，但我真的没有办法改进它。我目前运行多个片段来准备我的文件，然后完成最后一个片段，开始基于一些逻辑生成多个excel文件。

脚本似乎没有终止，但每次创建新文件后都会冻结。是什么让这个过程持续了好几天。(+-200个Excel文件作为输出(该报告的创建者声称，与他一起创作花了大约20分钟。不幸的是，我再也联系不上他了。

有人知道为什么这个剧本总是冻结吗？我是否也应该在本地更改一些设置？

Sub CreatePartnerFiles()
'On crŽe les fichiers Service Reports
Application.ScreenUpdating = False
Dim wbsrc As Workbook
Dim SRP As Workbook
Dim wbsrcp As Worksheet
Dim wbsrcparam As Worksheet
Dim SumTransaction As Long
Set wbsrc = Workbooks("Service Report Creator.xlsm")
Set wbsrcp = wbsrc.Sheets("Partner")
Set wbsrcua = wbsrc.Sheets("UserActions")
Set wbsrcparam = wbsrc.Sheets("Parameters")
Set wbsrcexc = wbsrc.Sheets("Exceptions")
NumPar = wbsrcp.Range("A1").End(xlDown).Row
NumAct = wbsrcua.Range("A1").End(xlDown).Row
Parscan = 2
wbsrcparam.Range("J:J") = ""
Dim MonthforFile As String
If Len(wbsrcparam.Range("B1")) = 1 Then
MonthforFile = "0" & wbsrcparam.Range("B1")
Else
MonthforFile = wbsrcparam.Range("B1")
End If
Do While Parscan <= NumPar
PartnerID = wbsrcp.Range("A" & Parscan)
If wbsrcp.Range("K" & Parscan) = 1 Then
wbsrcparam.Range("J1") = PartnerID
If wbsrcp.Range("L" & Parscan) = 1 Then
RowPar = WorksheetFunction.Match(PartnerID, wbsrcexc.Range("A1:A20"), 0) 'Trouve la ligne o apparait le Partner dans le tableau des exceptions
ExceptionCount = wbsrcexc.Cells(RowPar, 3) 'Nombre de partners en plus du principal ˆ inclure dans le rapport
ColPar = 4
CountParExc = 2
For I = ColPar To ColPar + ExceptionCount - 1
wbsrcparam.Range("J" & CountParExc) = wbsrcexc.Cells(RowPar, ColPar)
CountParExc = CountParExc + 1
ColPar = ColPar + 1
Next I
Else
wbsrcparam.Range("J2:J10") = ""
End If
'NewWB = wbsrcparam.Range("B2") & MonthforFile & "-" & wbsrcp.Range("E" & Parscan) & ".xlsx"
NewWB = "(" & wbsrcp.Range("A" & Parscan) & ") " & wbsrcp.Range("E" & Parscan) & ".xlsx"

Set SRP = Workbooks.Add
Set SRPWSPAR = SRP.Sheets("Sheet1")
SRPWSPAR.Name = "Trx"
SRP.SaveAs "/Users/XXX/OneDrive - XXX/August Reporting/" & NewWB

SRPWSPAR.Range("A1") = "Date"
SRPWSPAR.Range("B1") = "ID"
SRPWSPAR.Range("C1") = "Customer Name"
SRPWSPAR.Range("D1") = "Service Name"
SRPWSPAR.Range("E1") = "Service Code"
SRPWSPAR.Range("F1") = "Status"
SRPWSPAR.Range("G1") = "Total"
SRPWSPAR.Columns("A").ColumnWidth = 13
SRPWSPAR.Columns("B").ColumnWidth = 13
SRPWSPAR.Columns("C").ColumnWidth = 40
SRPWSPAR.Columns("D").ColumnWidth = 13
SRPWSPAR.Columns("E").ColumnWidth = 26
SRPWSPAR.Columns("F").ColumnWidth = 13
SRPWSPAR.Columns("G").ColumnWidth = 13
SRPWSPAR.Range("A1:G1").Font.Bold = True
SRPWSPAR.Range("A1:G1").Interior.Color = RGB(240, 240, 240)
K = 2
m = 2
Do While K <= NumAct
If Not wbsrcparam.Range("J1:J10").Find(wbsrcua.Range("B" & K), LookIn:=xlValues, LookAt:=xlWhole) Is Nothing Then
wbsrcua.Range("A" & K).EntireRow.Copy SRPWSPAR.Cells(m, 1)
SRPWSPAR.Range("A" & m).EntireRow.RowHeight = 19
If SRPWSPAR.Cells(m, 4) = "APPROVAL" Then
SRPWSPAR.Cells(m, 4) = "Confirm"
ElseIf SRPWSPAR.Cells(m, 4) = "SHARE" Then
SRPWSPAR.Cells(m, 4) = "Share"
ElseIf SRPWSPAR.Cells(m, 4) = "LOGIN" Then
SRPWSPAR.Cells(m, 4) = "Login"
Else
SRPWSPAR.Cells(m, 4) = "Sign"
End If
If SRPWSPAR.Cells(m, 6) = "DONE" Then
SRPWSPAR.Cells(m, 6) = "Done"
ElseIf SRPWSPAR.Cells(m, 6) = "DISMISSED" Then
SRPWSPAR.Cells(m, 6) = "Dismissed"
End If
m = m + 1
End If
K = K + 1
Loop
SumTransaction = Application.WorksheetFunction.Sum(SRPWSPAR.Range("G2:G" & m - 1))
SRPWSPAR.Range("G" & m).Value = SumTransaction
SRPWSPAR.Range("A" & m & ":G" & m).Font.Bold = True
SRPWSPAR.Range("A" & m & ":G" & m).Interior.Color = RGB(240, 240, 240)
'Remove link within file
Dim ExternalLinksArray As Variant
ExternalLinksArray = SRP.LinkSources(Type:=xlLinkTypeExcelLinks)
If IsEmpty(ExternalLinksArray) = False Then
For x = 1 To UBound(ExternalLinksArray)
SRP.BreakLink Name:=ExternalLinksArray(x), Type:=xlLinkTypeExcelLinks
Next x
End If
SRP.Save
SRP.Close
End If
Parscan = Parscan + 1
Loop
Application.ScreenUpdating = True
End Sub

Answer 1

这并不是真正要了解代码的情况，但如果你的文件有很多公式，将Calcualation切换到xlCalculationManual和EnableEvents可能有助于提高速度。

在顶部，(而不是Application.ScreenUpdate=False(

With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual

.EnableEvents = False
End With

On Error GoTo Error_Handler

在底部，(而不是Application.ScreenUpdate=True(

Error_Handler:
With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic

.EnableEvents = True
End With

在保存任何代码之前，

Application.Calculation = xlCalculationAutomatic

在保存代码之后，

Application.Calculation = xlCalculationManual

此外，你似乎正在OneDrive中保存所有这些文件？我自己不使用它，但把它存到其他地方可能会有帮助吗？我很想知道其中的区别。