How to resolve freezing of VBA Script

RobbeVL 0
Viewed 34

I recently inherited a VBA Script, and I dont really see a way to improve it. I currently run multiple pieces to prepare my file, and then finish with the last piece, to start generating multiple excel files, based on some logic.

The script doesnt seem to terminate, but it freezes after creating a new file everytime. What makes this process last for days probably. ( +- 200 Excel files as output) The builder of the report claims the creating with him took about 20 minutes. Unfortunately, I am not able to reach out to him anymore.

Anyone has an idea why this script freezes up all the time? MAybe some settings locally I should change as well?


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
vba excel
1 Answers

It's not really to undersatnd what's going on with the code, but if your files have lots of formulas, switching Calcualtion to xlCalculationManual and EnableEvents might help with speed.

At the top, (instead of Application.ScreenUpdating = False)

    With Application

        .ScreenUpdating = False

        .Calculation = xlCalculationManual
        
        .EnableEvents = False

    End With
    
    On Error GoTo Error_Handler

And at the bottom, (instead of Application.ScreenUpdating = True)

Error_Handler:

    With Application

        .ScreenUpdating = True

        .Calculation = xlCalculationAutomatic
        
        .EnableEvents = True

    End With

And before any code that saves,

Application.Calculation = xlCalculationAutomatic

And immediately after the code that saves,

Application.Calculation = xlCalculationManual

Also, it appears that you are saving all of these files in OneDrive? I don't use it myself but saving somewhere else might help? I'd be curious to know the difference.

userk1cj0
Related