Option Explicit
Private Sub Workbook_Open()
' Set network folder path
'Const FolderPath As String = "\\jacksonville-dc\common\test\SOPs With New Names"
' Set local folder path
Const FolderPath As String = "C:\Users\test\Desktop\SOP Audit Excel Prototype\SOPs"
' Set allowed file type(s)
Const FileExt As String = "docx"
' Instantiate FSO
Dim oFSO As Object
Dim oFolder As Object
Dim oFiles As Object
Dim oFile As Object
Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oFolder = oFSO.GetFolder(FolderPath)
Set oFiles = oFolder.Files
Dim v As Variant
Dim iSheet As Long
' Clear Worksheets
Dim ws As Worksheet
For Each ws In ThisWorkbook.Worksheets
ws.Cells.ClearContents
ws.Cells.Interior.Color = xlNone
Next ws
For Each oFile In oFiles
If LCase(Right(oFile.Name, 4)) = FileExt Then
v = Split(oFile.Name, "-")
Select Case v(3)
'Setup Select to determine dept values
Case "PNT", "VLG", "SAW"
Call pvtPutOnSheet(oFile.Path, 1, v)
Case "CRT", "AST", "SHP", "SAW"
Call pvtPutOnSheet(oFile.Path, 2, v)
Case "CRT", "STW", "CHL", "ALG", "ALW", "ALF", "RTE", "AFB", "SAW"
Call pvtPutOnSheet(oFile.Path, 3, v)
Case "SCR", "THR", "WSH", "GLW", "PTR", "SAW"
Call pvtPutOnSheet(oFile.Path, 4, v)
Case "PLB", "SAW"
Call pvtPutOnSheet(oFile.Path, 5, v)
Case "DES"
Call pvtPutOnSheet(oFile.Path, 6, v)
Case "AMS"
Call pvtPutOnSheet(oFile.Path, 7, v)
Case "EST"
Call pvtPutOnSheet(oFile.Path, 8, v)
Case "PCT"
Call pvtPutOnSheet(oFile.Path, 9, v)
Case "PUR", "INV"
Call pvtPutOnSheet(oFile.Path, 10, v)
Case "SAF"
Call pvtPutOnSheet(oFile.Path, 11, v)
Case "GEN"
Call pvtPutOnSheet(oFile.Path, 12, v)
End Select
End If
Next oFile
Call chkAuditDates
End Sub
Private Sub chkAuditDates()
'Set path to audits (NETWORK)
'Const FolderPath As String = "\\jacksonville-dc\common\test\SOP Audits with New Names"
'Set path to audits (LOCAL)
Const FolderPath As String = "C:\Users\test\Desktop\SOP Audit Excel Prototype\SOP Audits"
'Instantiate the FSO & related vars
Dim oFSO As Object: Set oFSO = CreateObject("Scripting.FileSystemObject")
Dim oFolder As Object: Set oFolder = oFSO.GetFolder(FolderPath)
Dim oFiles As Object: Set oFiles = oFolder.Files
Dim oFile As Object
'Loop through all worksheets - NEED TO ESTABLISH LOOP/CURRENTLY SET TO ONE SHEET
With Worksheets(1)
'Set cell background color to Red for a range of cells
With Range("E1:P" & .Cells(.Rows.Count, 1).End(xlUp).Row)
.Interior.Color = RGB(255, 0, 0)
.HorizontalAlignment = xlCenter
.Font.Color = vbBlack
.Font.Bold = True
End With
'Store cells in COL A that have values as a range
Dim SOPID As Range: Set SOPID = .Range("A1", .Range("A1").End(xlDown))
Dim cel As Range
'Loop through each SOP audit file
For Each oFile In oFiles
'Strip audit date out of filename and trim off the file extension
Dim auditDate: auditDate = CDate(DateSerial(Right(Left(Split(oFile.Name, "-")(3), 8), 4), _
Left(Left(Split(oFile.Name, "-")(3), 8), 2), _
Mid(Left(Split(oFile.Name, "-")(3), 8), 3, 2)))
'Loop through all SOP IDs stored in COL A
For Each cel In SOPID
'See if SOP ID in COL A matches SOP ID in Audit file name
If Trim(RemoveLeadingZeroes(Split(oFile.Name, "-")(2))) = Trim(cel) Then
'Insert link to audit, change background color, etc of selected cell
With cel.Offset(0, 3 + Month(auditDate))
.Hyperlinks.Add Anchor:=cel.Offset(0, 3 + Month(auditDate)), Address:=oFile.Path, TextToDisplay:="X"
.Interior.Color = RGB(34, 139, 34)
.Font.Color = vbBlack
.Font.Bold = True
End With
End If
Next cel
Next oFile
End With
'Loop through each worksheet
'Set red bgcolor for a range of cells for Jan-Current Month
'Loop through each file
'Break filename apart with Split(); looking for SOP ID and the Date
'Loop through each cell in range: "SOP IDs" to see if cell value matches SOP ID in audit filename (Filename(2))
'If there is a match, use the month in the date in Filename(3), to determine which Column to put the link in (E-P:Jan-Dec)
'Use Offset() from the COL A cell being used to insert the link
End Sub
Private Sub pvtPutOnSheet(sPath As String, i As Long, v As Variant)
Dim r As Range
With Worksheets(i)
Set r = .Cells(.Rows.Count, 1).End(xlUp)
If Len(r.Value) > 0 Then Set r = r.Offset(1, 0) ' next empty cell in Col A
If UBound(v) > 3 Then
r.Value = v(2) ' Col A = "001"
r.Offset(0, 1).Value = v(3) ' Col B = "CHL"
'Create hyperlink in each cell
.Hyperlinks.Add Anchor:=r.Offset(0, 2), Address:=sPath, TextToDisplay:=v(4) ' Col C = "Letter Lock for Channel Letters" with link to Path
r.Offset(0, 3).Value = Left(v(5), 2) ' Col = "EN"
End If
End With
End Sub
Function RemoveLeadingZeroes(ByVal str)
Dim tempStr
tempStr = str
While Left(tempStr, 1) = "0" And tempStr <> ""
tempStr = Right(tempStr, Len(tempStr) - 1)
Wend
RemoveLeadingZeroes = tempStr
End Function