2
\$\begingroup\$

I was wondering if anyone has any improvement ideas for my code. At the moment it is somewhat sluggish though it does work. This is my first project in VBA; I come from a background in PHP/Python.

    Option Explicit

Private Sub Workbook_Open()

'   Set network folder path
    Const FolderPath As String = "\\JACKSONVILLE-DC\Common\SOP's for JV\SOPs Final"
'   Set local folder path
    'Const FolderPath As String = "C:\Users\jbishop\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
        ws.Range("A1").Value = "SOP ID"
        ws.Range("B1").Value = "DEPT"
        ws.Range("C1").Value = "SOP TITLE"
        ws.Range("D1").Value = "LANG"
        ws.Range("E1").Value = "JAN"
        ws.Range("F1").Value = "FEB"
        ws.Range("G1").Value = "MAR"
        ws.Range("H1").Value = "APR"
        ws.Range("I1").Value = "MAY"
        ws.Range("J1").Value = "JUN"
        ws.Range("K1").Value = "JUL"
        ws.Range("L1").Value = "AUG"
        ws.Range("M1").Value = "SEP"
        ws.Range("N1").Value = "OCT"
        ws.Range("O1").Value = "NOV"
        ws.Range("P1").Value = "DEC"
        ws.Range("A1:P1").Font.Color = vbBlack
        ws.Range("A1:P1").Font.Bold = True
        ws.Range("A1:P1").Font.Underline = False
    Next ws

    'Loop through each file in FSO
    For Each oFile In oFiles
        If LCase(Right(oFile.Name, 4)) = FileExt Then

            'Split filename
            v = Split(oFile.Name, "-")
            'MsgBox (v(3))
            'Exit Sub
            'Use dept code as Select variable
            Select Case v(3)
                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 Sub Procedure that will cross check SOPs with SOP audits
    Call chkAuditDates
End Sub


Private Sub chkAuditDates()
    'Set path to audits (NETWORK)
    Const FolderPath As String = "\\JACKSONVILLE-DC\Common\SOP's for JV\SOP Audits\2019"
    'Set path to audits (LOCAL)
    'Const FolderPath As String = "C:\Users\jbishop\Desktop\SOP Audits with New Names"

    '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

    Dim i As Integer
    'Loop through all worksheets - NEED TO ESTABLISH LOOP/CURRENTLY SET TO ONE SHEET
    For i = 1 To 4
        With Worksheets(i)
            '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("A" & .Rows.Count).End(xlUp))
            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

            'Autosize columns to best fit inserted data
            .Columns("A:P").AutoFit
        End With
    Next i
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

The filenames look like this:

  • SOP_Audit-JV-001-05152019
  • SOP-JV-001-CHL-Letter Lock for Channel Letters-EN

Any input is much appreciated. Thank you everyone.

\$\endgroup\$
3
\$\begingroup\$

Many areas to comment here.

Well done on including Option Explicit and good indenting!

I have identified some key themes:

  • Avoiding repetition
  • Avoid magic numbers
  • Meaningful variable names
  • Avoid switching between Excel and VBA unless really necessary
  • Properly qualify calls to Excel objects

Avoiding repetition

While there is not a lot of obvious repetition, avoiding it as much as possible makes maintenance easier. A significant example here is in your Select statement:

            Case "PNT", "VLG", "SAW"
                Call pvtPutOnSheet(oFile.Path, 1, v)

This has multiple sins:

  • the same call is repeated 12 times
  • the call uses magic numbers
  • the call uses a variable which is not clear what it does (v)

A way around it is:

Select Case fileNameParts(3)
    Case "PNT", "VLG", "SAW"
        relevantSheet = 1
' [. . . ]
End Case
PutOnSheet oFile.Path, relevantSheet, fileNameParts '<-- proper VBA syntax for calling a routine

Avoid magic numbers

'Magic Numbers' make life harder when returning to code, or if someone else looks at your code. Why do you have '1'? what does '13' mean? What if your filename syntax changes, and you need v(4) instead of v(3)?

In one of my code projects, I have set a module aside (imaginatively called 'MagicNumbers') in which I declare all magic numbers as Public Const. While they may not need to be public (your file path Const is an example here), putting them in once place makes management easier - and makes retiring them easier when you modify your code.

I also use a convention, all Constants are in UPPERCASE, and have meaningful names so the code is self-commenting.

Public Const FINALFILEPATH As String = "\\JACKSONVILLE-DC\Common\SOP's for JV\SOPs Final"

(and an example of use)

Set oFolder = oFSO.GetFolder(FINALFILEPATH)

Meaningful variable names

You will come back in 3 months and have to work out what v, i, iSheet, r, cel, sPath, SOPID really represent. In this day and age, storage is cheap so using meaningful names makes your life a lot easier.

  • v is an array of fileNameParts
  • i has been used both as an iterator and a relevantWorkSheet
  • iSheet is not a bedcovering sold by Apple, but is also not used in the code
  • r is the lastCell, but what you are really interesting in is nextEmptyCell
  • sPath is filePath

And your functions and routines should also be well named. pvtPutOnSheet is really PutOnSheet - no need for a funky Hungarian notation.

Avoid switching

Do as much as possible in the VBA environment. Use arrays instead of dealing directly with Excel range values.

For Each ws In ThisWorkbook.Worksheets
    ws.Cells.ClearContents
    ws.Cells.Interior.Color = xlNone
    ws.Range("A1").Value = "SOP ID"
    ws.Range("B1").Value = "DEPT"
    ws.Range("C1").Value = "SOP TITLE"
    ws.Range("D1").Value = "LANG"
    ws.Range("E1").Value = "JAN"
    ws.Range("F1").Value = "FEB"
    ws.Range("G1").Value = "MAR"
    ws.Range("H1").Value = "APR"
    ws.Range("I1").Value = "MAY"
    ws.Range("J1").Value = "JUN"
    ws.Range("K1").Value = "JUL"
    ws.Range("L1").Value = "AUG"
    ws.Range("M1").Value = "SEP"
    ws.Range("N1").Value = "OCT"
    ws.Range("O1").Value = "NOV"
    ws.Range("P1").Value = "DEC"
    ws.Range("A1:P1").Font.Color = vbBlack
    ws.Range("A1:P1").Font.Bold = True
    ws.Range("A1:P1").Font.Underline = False
Next ws

Can become:

Dim headings as Variant
headings = Array("SOP ID", "Dept", "SOP Title", "...") '<--- etc, you get the idea
For Each ws In ThisWorkbook.Worksheets
    ws.Cells.ClearContents
    ws.Cells.Interior.Color = xlNone
    With ws.Range("A1:P1") ' Magic number Const HEADINGRANGE as String = "A1:P1"
        .Value = headings '<-- touch Excel once here instead of 16 times.
        .Font.Color = vbBlack
        .Font.Bold = True
        .Font.Underline = False
    End With
Next ws

Properly qualify calls

You have a mixture of well qualified calls (ensuring correct behaviour) and unqualified calls (random behaviour depending on active and selected sheets).

The following is an easy omission to make:

    With Worksheets(i)
        'Set cell background color to Red for a range of cells
        With Range("E1:P" & .Cells(.Rows.Count, 1).End(xlUp).Row)

I think you meant .Range, but that now works on the active sheet, and not Worksheets(i)

Miscellaneous

Functions should return something, and better coding practice is to strongly type this, rather than leaving an implied variant.

Function RemoveLeadingZeroes(ByVal str) as String

Early bind instead of late bind - it is more efficient (except when working across different Windows versions or different Office versions). It also allows for intellisense which makes coding and debugging a lot easier!

' Add reference to Scripting so you can natively access the FileSystemObject
Dim oFSO As FileSystemObject
Dim oFolder As Folder
Dim oFiles As Files
Dim oFile As File

Set oFSO = New FileSystemObject
Set oFolder = oFSO.GetFolder(FolderPath)
Set oFiles = oFolder.Files

Put each line of code on a separate line - this makes it easier to find, read and debug. If your code is reaching the VBA IDE maximum, then it is time to review the code and how it is broken up. As an example:

Dim oFSO As Object: Set oFSO = CreateObject("Scripting.FileSystemObject")

should be

Dim oFSO As Object
Set oFSO = CreateObject("Scripting.FileSystemObject")

or, in line with previous comment:

Dim oFSO As FileSystemObject
Set oFSO = New FileSystemObject
\$\endgroup\$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.