Saving excel files to network drive takes too long using VBA - excel

Question

I have a macro which loops through excel files in a network drive path and performs few operations on the pivots and then tries to save the file in the same network path.
It works fine for the first 5 - 10 files and then it randomly stops saving the files.
The progress bar in the save box does not go any further.
Unable to save image
I have included the VBA code below
Sub CLEAR_ADI_PIVOT_DT_SRC()
Dim myPath As String
Dim myExtension As String
Dim myFile As String
Dim wb As Workbook
Dim ws As Worksheet
Dim FilePath As String
Dim PriorQuarter As String
Dim PrevQtrSheet As String
Dim filestr1 As String
Dim PrevQuarter As String
PrevQtrSheet = "Rebates Template " & Range("B2").Value
PrevQuarter = Range("B2").Value
PriorQuarter = Range("A2").Value
myPath = Range("I2").Value & "ADI\"
If Right(myPath, 1) <> "\" Then
myPath = myPath & "\"
End If
On Error GoTo ErrHandler
'Optimize Macro Speed
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
'Target File Extension (must include wildcard "*")
myExtension = "*.xl*"
'Target Path with Ending Extension
myFile = Dir(myPath & myExtension)
'Loop through each Excel file in folder
Do While myFile <> ""
'Set variable equal to opened workbook
Application.DisplayAlerts = False
Debug.Print myPath & myFile
Set wb = Workbooks.Open(filename:=myPath & myFile, UpdateLinks:=False)
wb.Worksheets("ADI").Visible = True
wb.Worksheets("ADI").Activate
Cells.Find(What:="totals:", After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate
ActiveCell.Offset(-1, 0).Select
Dim AdiClearRange As Range
Set AdiClearRange = Range("AE" & ActiveCell.Row, "C14")
AdiClearRange.Select
Selection.ClearContents
Range("B15").Select
'Insert rows in ADI sheet
Dim x As Long
For x = 1 To 500
Range("B19:AE19").Select
Selection.Copy
Selection.Insert Shift:=xlDown
Range("B14").Select
Application.CutCopyMode = False
Next x
'Delete prior quarter template sheet
For Each Sheet In wb.Worksheets
If Sheet.Name = "Rebates Template " & PriorQuarter Then
Sheet.Delete
End If
Next Sheet
'change data source of previous quarter pivots
'Get range of the previous template
wb.Worksheets(PrevQtrSheet).Activate
Range("AH5").Select
If ActiveSheet.AutoFilterMode Then ActiveSheet.AutoFilter.ShowAllData
ActiveSheet.Range("$A$5:$KD$683").AutoFilter Field:=34, Criteria1:="<>"
'ActiveSheet.Range("$A$5:$KD$683").AutoFilter Field:=34, Criteria1:="<>0"
Range("AH5").Select
Selection.End(xlDown).Select
'Change range of pivot 1 and pivot 7 and apply previous quarter filter in pivots
Dim rng As Range
Dim SourceAddress As String
Set rng = Range("A5", "AH" & ActiveCell.Row)
SourceAddress = "'" & PrevQtrSheet & "'" & "!" & "$A$5:" & ActiveCell.Address(RowAbsolute:=True, ColumnAbsolute:=True)
Debug.Print SourceAddress
Sheets("Check").Select
Dim myPivotField As PivotField
Dim filterValue As String
ActiveSheet.PivotTables("PivotTable3").ChangePivotCache wb.PivotCaches.Create(SourceType:=xlDatabase, SourceData:=SourceAddress)
ActiveSheet.PivotTables("PivotTable3").RefreshTable
ActiveSheet.Range("P1").Value = PrevQuarter
wb.Close SaveChanges:=True
'Get next file name
myFile = Dir
Loop
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
ResetSettings:
'Reset Macro Optimization Settings
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
ErrHandler:
'MsgBox Err.Description, vbExclamation
'Resume ResetSettings
End Sub