We need to run a VBA program to update over 500+ workbooks (removing and changing a worksheet in each of them).
The below VBA program does a recursive traversal of all the workbook.
ISSUE
After doing anywhere from 50, 200, or sometimes 400 the macro stops. No errors. It just leaves an open workbook on the screen. it is always a different workbook, and often times it processes the offender, so it does not seem to be content related.
I thought it might be the
GetFilesRecursive fso.GetFolder(directory), "xlsx", files, fso
which which is getting confused because of the update of the workbook with the SAVE. But I have also tried putting the output via SAVAS in a seperate folder tree, and that does not affect things.
Any idea how one debugs such an issue?
Const ProgDir = "D:\Staffing\SkillsUpdate\ProgramOfficeData"
Sub allPrograms(directory As String)
Dim fso As New Scripting.FileSystemObject
Dim files As New Collection
Dim file As Scripting.file
Dim result As Boolean
Dim index As Integer
clearErrors
GetFilesRecursive fso.GetFolder(directory), "xlsx", files, fso
index = 1
For Each file In files
If file Is Nothing Then
' Do nothing
Else
result = oneProgram(file.ParentFolder.path, file.Name)
Application.StatusBar = "Processing " & index & " of " & files.count
If (result) Then
index = index + 1
End If
End If
' logError "allPrograms(): processed:", 0, directory & "\" & file
Next file
Application.ThisWorkbook.Activate
Worksheets("Main").Cells(4, 3).Value = "Last Update: " + Format(Now(), "General Date")
End Sub
Function oneProgram(directory As String, fileName As String) As Boolean
Dim wbk As Workbook
Dim filePath As String
Dim result As Boolean
filePath = directory & "\" & fileName
Set wbk = safeOpen(filePath, result)
If (Not result) Then
oneProgram = False
Exit Function
End If
killSkillNames wbk
clearProgSkills wbk
copyDropList wbk
copySkillsList wbk
addSkillNames wbk
addWinPercent wbk
hideProgSheets wbk
wbk.Close SaveChanges:=True
oneProgram = True
End Function
Sub hideProgSheets(wbk As Workbook)
wbk.Worksheets("SkillsList").Visible = False
wbk.Worksheets("DropLists").Visible = False
End Sub
Sub copyDropList(wbk As Workbook)
Dim source As Worksheet
Dim target As range
Dim dest As Worksheet
Set source = Application.ThisWorkbook.Worksheets("DropLists")
Set dest = wbk.Sheets("DropLists")
wbk.Names("YesNoList").Delete
Set target = wbk.Worksheets("StaffRequest").range("J3:K3")
target.Validation.Delete 'delete previous validation
Application.DisplayAlerts = False
dest.Delete
Application.DisplayAlerts = True
source.Copy wbk.Sheets(Sheets.count)
wbk.Names.Add Name:="YesNoList", RefersTo:=wbk.Sheets("DropLists").range("A1:A2")
End Sub
Sub addWinPercent(wbk As Workbook)
Dim target As range
wbk.Names.Add Name:="WinPercent", RefersTo:=wbk.Sheets("DropLists").range("B1:B5")
Set target = wbk.Worksheets("StaffRequest").range("J3:K3")
With target.Validation
.Add Type:=xlValidateList, _
Operator:=xlBetween, _
AlertStyle:=xlValidAlertStop, _
Formula1:="=WinPercent"
End With
End Sub
Sub clearProgSkills(wbk As Workbook)
Dim target As range
Set target = wbk.Worksheets("StaffRequest").range("H10:J100")
For Each cell In target
If (cell.Value <> "") And (cell.Value <> "Total") Then
cell.Value = "No Skill"
End If
Next cell
End Sub
Sub RUNME_PROGRAMS()
allPrograms (ProgDir)
End Sub
Sub GetFilesRecursive(f As Scripting.Folder, filter As String, c As Collection, fso As Scripting.FileSystemObject)
Dim sf As Scripting.Folder
Dim file As Scripting.file
For Each file In f.files
If InStr(1, fso.GetExtensionName(file.Name), filter, vbTextCompare) = 1 Then
c.Add file, file.path
End If
Next file
For Each sf In f.SubFolders
GetFilesRecursive sf, filter, c, fso
Next sf
End Sub
Function safeOpen(filePath As String, result As Boolean) As Workbook
result = True
Dim book As Workbook
Dim lockTest As Boolean
Dim errCode As Integer
Dim errText As String
lockTest = IsWorkBookOpen(filePath, errCode, errText)
If (lockTest) Then
logError "safeOpen: Open Problem with: " & filePath, errCode, errText
result = False
Exit Function
End If
On Error Resume Next ' turn off error trapping
Set book = Workbooks.Open(fileName:=filePath, ReadOnly:=False, UpdateLinks:=False)
On Error GoTo 0 ' turn on error trapping
If book Is Nothing Then
logError "safeOpen: cannot Open File: " & filePath, errCode, errText
result = False
End If
Set safeOpen = book
End Function
Function safeCellRead(rng As range) As Double
If (IsNumeric(rng.Value)) Then
safeCellRead = CDbl(rng.Value)
Else
safeCellRead = 0
End If
End Function
Function IsWorkBookOpen(strFileName As String, errCode As Integer, errText As String) As Boolean
On Error Resume Next
' If the file is already opened by another process,
' and the specified type of access is not allowed,
' the Open operation fails and an error occurs.
Open strFileName For Binary Access Read Write Lock Read Write As #1
Close #1
errCode = Err.Number
errText = Err.description
'If no error, file is not open.
If Err.Number = 0 Then
IsWorkBookOpen = False
End If
'Error #70 is another user has the file open in edit mode.
If Err.Number = 70 Then
IsWorkBookOpen = True
End If
'Error #75 is another user has the file open in read only mode.
If Err.Number = 75 Then
IsWorkBookOpen = False
End If
On Error GoTo 0 ' turn on error trapping
End Function
Sub copySkillsList(wbk As Workbook)
Dim source As Worksheet
Dim dest As Worksheet
Set source = Application.ThisWorkbook.Worksheets("SkillsList")
Set dest = wbk.Sheets("SkillsList")
dest.Unprotect Password:="****"
Application.DisplayAlerts = False
dest.Delete
Application.DisplayAlerts = True
source.Copy wbk.Sheets(Sheets.count)
End Sub
Sub killSkillNames(wkb As Workbook)
Dim skills As Worksheet
Dim range As range
Dim tag As String
Dim cell As range
Set skills = wkb.Worksheets("SkillsList")
Set range = skills.range("A1:AZ1")
For Each cell In range
If cell <> "" Then
tag = cell.Value
wkb.Names(tag).Delete
End If
Next cell
End Sub
Sub addSkillNames(wkb As Workbook)
Dim skills As Worksheet
Dim values As range
Dim top As range
Dim bottom As range
Dim tag As String
Dim cell As range
Set skills = wkb.Worksheets("SkillsList")
Set headers = skills.range("A1:AZ1")
For Each cell In headers
If cell <> "" Then
tag = cell.Value
Set top = cell.Offset(1, 0)
Set bottom = top.End(xlDown)
Set values = range(top, bottom)
wkb.Names.Add Name:=tag, RefersTo:=values
End If
Next cell
End Sub
Sub clearErrors()
Dim eSheet As Worksheet
Set eSheet = Worksheets("ErrorLog")
eSheet.range("A2:E4000").Clear
eSheet.range("A1").Value = 1
Application.DisplayStatusBar = True
Application.StatusBar = ""
End Sub
Sub logError(errText As String, errNum As Integer, errDescription As String)
Dim eSheet As Worksheet
Dim eCount As Integer
Set eSheet = ThisWorkbook.Worksheets("ErrorLog")
eCount = CInt(eSheet.range("A1"))
eCount = eCount + 1
eSheet.Cells(eCount, 2).Value = errNum
eSheet.Cells(eCount, 3).Value = errText
eSheet.Cells(eCount, 4).Value = errDescription
Application.StatusBar = "ERROR: " & eText
eSheet.range("A1").Value = eCount
End Sub
