TMP file not found error when creating multiple workbooks in a loop
Hi all. I'm new so please show some grace and my apologies for any failure to follow forum conduct...
I have done my best to research this and can find the topic, but no solution:
I have a macro that loops through some code that:
updates fields on a sheet
opens a new book
copies the sheet into the new book
saves and closes the new book
opens a new email in outlook
attached the new book
This code will loop a few times (not a consistent number), then usually errors with:
Code:
File not found" 'C:\Users\me\AppData\Local\Temp\VB***x.tmp'
There is also an unnamed book created (BookX) and a blank sheet inserted in the front but it's empty and named Sheet4
When I debug, it's always stopped on the same line and if I simply continue the macro it will finish - or eventually finish if it errors again and I continue clicking play.
I added a line to wait a couple seconds because it seemed like a timing problem, but it still will error.
I'm in testing right now, so the data is the same each time I run it but, as mentioned above, it doesn't fail at the same time.
As an example, I just tried to run it 3 times and it error in the 2nd loop, 11th loop, and 3rd loop.
The entire code is below and the line that it stops on is red.
Thanks in advance for any support!
Code:
Option Explicit
Sub BuildAudits()
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''''Get last row of data on TempSwaps
Dim LastRowAuditAssignment As Long
With Sheets("AuditAssignment")
LastRowAuditAssignment = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim wk As String, yr As String
Dim FName As String, FPath As String
Dim owb As Workbook
With Application
.DisplayAlerts = False
.ScreenUpdating = False
.EnableEvents = False
End With
Dim i As Integer
Dim CurrLoc As String
Dim CurrDate As String
Dim CurrFileDate As String
Dim CurrScorer As String
Dim PrevScore As String
Dim CurrFileName As String
Dim SendTo As String
For i = 4 To LastRowAuditAssignment
With Sheets("AuditAssignment").Range("A:Z")
CurrLoc = .Cells(i, 2)
CurrDate = Format(Now(), "mm/dd/yy")
CurrFileDate = Format(Now(), "mmddyy")
CurrScorer = .Cells(i, 1)
PrevScore = .Cells(i, 7)
CurrFileName = "5S Audit-" & CurrScorer & "-" & CurrFileDate & ".xlsx"
SendTo = .Cells(i, 6)
End With
With Sheets("AuditAssignmentHistory")
.Range("A2").EntireRow.Insert
.Cells(2, 1) = CurrFileName
.Cells(2, 2) = CurrDate
.Cells(2, 3) = CurrScorer
.Cells(2, 4) = CurrLoc
End With
With Sheets("Production 5S")
.Range("val_FileNameRef") = ""
.Range("val_Location") = ""
.Range("val_Date") = ""
.Range("val_ScoredBy") = ""
.Range("val_PrevScore") = ""
.Range("val_FileNameRef") = CurrFileName
.Range("val_Location") = CurrLoc
.Range("val_Date") = CurrDate
.Range("val_ScoredBy") = CurrScorer
.Range("val_PrevScore") = PrevScore
Dim j As Integer
For j = 1 To 25
.Range("val_Wk" & Format(j, "00")) = j
.Range("val_Score" & Format(j, "00")) = j
Next j
End With
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''''Delete and re-add TempSwaps sheet
Application.DisplayAlerts = False
Sheets("TempSwaps").Delete
Application.DisplayAlerts = True
Dim sheet As Worksheet
Set sheet = Sheets.Add
sheet.Name = "TempSwaps"
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''''Unfilter Sheet
If Sheets("AuditAssignmentHistory").AutoFilterMode Then Sheets("AuditAssignmentHistory").AutoFilter.ShowAllData
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''''Filter by area and copy
Sheets("AuditAssignmentHistory").Range("$A$1:$BC$" & Sheets("RefData").Range("val_HistoryCount") + 1).AutoFilter Field:=4, _
Criteria1:=CurrLoc
Sheets("AuditAssignmentHistory").Range("B1:AD" & Sheets("RefData").Range("val_HistoryCount")).Copy
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''''Paste in TempSwaps sheet
With Sheets("TempSwaps").Range("A1")
.PasteSpecial xlPasteFormats
.PasteSpecial xlPasteValues
Application.CutCopyMode = False
End With
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''''Get last row of data on TempSwaps
Dim LastRowTempSwaps As Long
With Sheets("TempSwaps")
LastRowTempSwaps = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''''Sort by newest date first
ActiveWorkbook.Worksheets("TempSwaps").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("TempSwaps").Sort.SortFields.Add Key:=Range( _
"A2:A" & LastRowTempSwaps), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:= _
xlSortNormal
With ActiveWorkbook.Worksheets("TempSwaps")
.Sort.SetRange Range("A1:AC" & LastRowTempSwaps)
.Sort.Header = xlYes
.Sort.MatchCase = False
.Sort.Orientation = xlTopToBottom
.Sort.SortMethod = xlPinYin
.Sort.Apply
End With
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''''Load weeks and audit scores in sheet
Dim m As Integer
Dim RefColumn As Integer
Dim ThisScore As Integer
ThisScore = 0
For m = 1 To 25
RefColumn = 4 + m
ThisScore = Sheets("TempSwaps").Cells(2, RefColumn)
With Sheets("Production 5S")
.Range("val_Score" & Format(m, "00")) = ThisScore
Dim k As Integer
Dim ThisScoreCount As Integer
ThisScoreCount = 0
For k = 2 To LastRowTempSwaps
If Sheets("TempSwaps").Cells(k, RefColumn) = ThisScore Then
ThisScoreCount = ThisScoreCount + 1
Else
k = LastRowTempSwaps + 1
End If
Next k
.Range("val_Wk" & Format(m, "00")) = ThisScoreCount
End With
Next m
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''''Copy Out Audit Sheet'''''
Application.DisplayAlerts = False
Dim NewBook As Workbook
FPath = "C:\Users\rclark\Desktop\PCS 5S Audits\Open Audits"
FName = CurrFileName
Set NewBook = Workbooks.Add
ThisWorkbook.Sheets("Production 5S").Copy Before:=NewBook.Sheets(1) 'code stops at this line on error
NewBook.SaveAs Filename:=FPath & "\" & FName
NewBook.Close False
'Workbooks(FName).Close
'''''Wait a second to avoid "File Not Found"
'Application.Wait Now + #12:00:05 AM#
Application.DisplayAlerts = True
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''''Send Email to Auditor'''''
Dim OutApp As Object
Dim OutMail As Object
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = SendTo
.CC = Sheets("RefData").Range("val_CC")
.BCC = ""
.Subject = "5S Audit for " & CurrScorer & " week of " & CurrDate
.Body = "Please see attached for your 5S audit assigment for the week of " & CurrDate & vbNewLine & _
"Your assigned location is: " & CurrLoc & "." & vbNewLine & _
"Please perform the audit, enter the results into the provided Excel sheet and email back to me before the end of the week" & vbNewLine & _
"Thank You."
.Attachments.Add (FPath & "\" & FName)
If Sheets("AuditAssignment").Range("val_EmailCheck") = "Review First" Then
.Display
Else
.Send 'or use .Display
End If
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Next i
With Application
.DisplayAlerts = True
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
