Consulting

Page 1 of 2 1 2 LastLast
Results 1 to 20 of 22

Thread: Suggestions regarding speed and efficiency

  1. #1
    VBAX Regular
    Joined
    Jul 2019
    Posts
    51
    Location

    Suggestions regarding speed and efficiency

    Hello everyone,

    I was just wondering if anyone would mind taking a look at my code to tell me if there is a way to do anything better? It functions as I want, but I haven't run it against the network yet. It's one thing when it's pulling files locally, I've run into problems in the past when I would run it on the network though.

    The newest part of the code is the Sub chkAuditDates.

    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

  2. #2
    VBAX Expert
    Joined
    May 2016
    Posts
    604
    Location
    You have a loop which is executed many many times which is accessing every cell in a range. this is inevitably going to be slow. One of the most frequent causes of slow vba is the time taken to access the worksheet. So one of my ways of speeding up vba is to minimise the number of worksheet accesses, specially in a long loop. It is worth noting that the time taken to load an entire range into a variant array is not much morethan the time to load a single cell . so to speed this up I would change this code:
              '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
    to something like this: (untested)
    Dim sopidarr As Variant
    sopidarr = .Range("A1", .Range("A1").End(xlDown))
     
     For i = 1 To UBound(sopidarr, 1)
                       If Trim(RemoveLeadingZeroes(Split(oFile.Name, "-")(2))) = Trim(sopidarr(i, 1)) Then
                        'Insert link to audit, change background color, etc of selected cell
                        With .Cells(i, 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 i
    Depending on the size of the array this could make a lot of difference, using variant arrays is often 1000 time faster

  3. #3
    VBAX Regular
    Joined
    Jul 2019
    Posts
    51
    Location
    Is there a way to use a link to activate a Sub onClick; instead of using a button?

    All the research I've done indicates that I can't put a button into a cell for alignment purposes...all of the alignment is done with relative positioning. I thought maybe I could insert a link into cells and use that as a button...

  4. #4
    VBAX Regular
    Joined
    Jul 2019
    Posts
    51
    Location
    Why do sopidarr as a variant vs a range? Is one data type faster than the other?

    Quote Originally Posted by offthelip View Post
    You have a loop which is executed many many times which is accessing every cell in a range. this is inevitably going to be slow. One of the most frequent causes of slow vba is the time taken to access the worksheet. So one of my ways of speeding up vba is to minimise the number of worksheet accesses, specially in a long loop. It is worth noting that the time taken to load an entire range into a variant array is not much morethan the time to load a single cell . so to speed this up I would change this code:
              '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
    to something like this: (untested)
    Dim sopidarr As Variant
    sopidarr = .Range("A1", .Range("A1").End(xlDown))
     
     For i = 1 To UBound(sopidarr, 1)
                       If Trim(RemoveLeadingZeroes(Split(oFile.Name, "-")(2))) = Trim(sopidarr(i, 1)) Then
                        'Insert link to audit, change background color, etc of selected cell
                        With .Cells(i, 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 i
    Depending on the size of the array this could make a lot of difference, using variant arrays is often 1000 time faster

  5. #5
    VBAX Regular
    Joined
    Jul 2019
    Posts
    51
    Location
    I'm getting a type mismatch on For i=1 To UBound(arrSOPID, 1)
                
                'Loop through all SOP IDs stored in COL A            For i = 1 To UBound(arrSOPID, 1)
                    'See if SOP ID in COL A matches SOP ID in Audit file name
                    If Trim(RemoveLeadingZeroes(Split(oFile.Name, "-")(2))) = Trim(arrSOPID(i, 1)) 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 i

  6. #6
    VBAX Regular
    Joined
    Jul 2019
    Posts
    51
    Location
    The type mismatch is fixed with changing the arrSOPID over to a range. But, my WITH .Cells won't work...Can someone explain what I am doing wrong?

    Dim i As Long: i = 0            'Loop through all SOP IDs stored in COL A
                For i = 1 To UBound(arrSOPID, 1)
                    myStr = arrSOPID(i, 1)
                    'cel = arrSOPID(i, 1)
                    'MsgBox (myStr)
                    'See if SOP ID in COL A matches SOP ID in Audit file name
                    If Trim(RemoveLeadingZeroes(Split(oFile.Name, "-")(2))) = Trim(myStr) Then
                        'Insert link to audit, change background color, etc of selected cell
                        With .Cells(i, 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 i

  7. #7
    VBAX Expert Leith Ross's Avatar
    Joined
    Oct 2012
    Location
    San Francisco, California
    Posts
    552
    Location
    Hello mongoose,

    The period before an object indicates that it is part of a With statement. Your line below indicates that Cells belongs to another With statement block.
    With .Cells(i, 3 + Month(auditDate))
    I believe you want to use the Active Worksheet cells. If that is the case remove the period before Cells.
    Sincerely,
    Leith Ross

    "1N73LL1G3NC3 15 7H3 4B1L17Y 70 4D4P7 70 CH4NG3 - 573PH3N H4WK1NG"

  8. #8
    VBAX Regular
    Joined
    Jul 2019
    Posts
    51
    Location
    Run-time error '91': Object variable or With block variable not set.

            'Store cells in COL A that have values as a range        Dim arrSOPID As Variant: arrSOPID = .Range("A1", .Range("A1").End(xlDown))
            Dim cel As Range
            Dim myStr As String
            
            '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)))
                
                Dim i As Long: i = 0
                'Loop through all SOP IDs stored in COL A
                For i = 1 To UBound(arrSOPID, 1)
                    MsgBox (i)
                    myStr = arrSOPID(i, 1)
                    'cel = arrSOPID(i, 1)
                    'MsgBox (myStr)
                    'See if SOP ID in COL A matches SOP ID in Audit file name
                    If Trim(RemoveLeadingZeroes(Split(oFile.Name, "-")(2))) = Trim(myStr) Then
                        'Insert link to audit, change background color, etc of selected cell
                        Dim monthCol As Long: monthCol = 3 + Month(auditDate)
                        'MsgBox (arrSOPID(i + monthCol, 1))
                        With Cells(i, 4 + 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 i
            Next oFile
    I'm at a total loss at trying to convert this code over to how Offthelip​ had suggested.

  9. #9
    VBAX Expert
    Joined
    May 2016
    Posts
    604
    Location
    Why do sopidarr as a variant vs a range? Is one data type faster than the other?
    to answer your query from some time back ( apologies for the delay, I have been away)
    manipulating Variant data types is usually about 1000 times faster than manipulating Range data types!!. This is because the range data type has to access the worksheet everytime you use it, this takes a long time i.e milliseconds for each access
    I have gone through your code and hoepfully got rid of a number of errors for you , try this:
         'Store cells in COL A that have values as a range        : arrSOPID = .Range("A1", .Range("A1").End(xlDown))
            Dim arrSOPID As Variant
            Dim cel As Range
            Dim myStr As String
            Dim monthCol As Long
            Dim i As Long
            '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)))
                ' find last row of active sheet
                lastrow = Cells(Rows.Count, "A").End(xlUp).Row
                ' load column A into variant array
                arrSOPID = Range(Cells(1, 1), Cells(lastrow, 1))
                
                
                'Loop through all SOP IDs stored in COL A
                For i = 1 To lastrow
    '                MsgBox (i)
                    myStr = arrSOPID(i, 1)
                    'cel = arrSOPID(i, 1)
                    'MsgBox (myStr)
                    'See if SOP ID in COL A matches SOP ID in Audit file name
                    If Trim(RemoveLeadingZeroes(Split(oFile.Name, "-")(2))) = Trim(myStr) Then
                        'Insert link to audit, change background color, etc of selected cell
                         ' cvalculate column to putthe link in
                         monthCol = 4 + Month(auditDate)
                        'MsgBox (arrSOPID(i + monthCol, 1))
                        With ActiveSheet
                        .Hyperlinks.Add Anchor:=.Range(Cells(i, monthCol), Cells(i, monthCol)), _
                                    Address:=oFile.Path, _
                                    TextToDisplay:="X"
                       End With
                    End If
                Next i
            Next oFile

  10. #10
    VBAX Sage
    Joined
    Apr 2007
    Location
    United States
    Posts
    8,711
    Location
    Minor tweaks to consider

    You could Dim auditDate one time

    I think getting the auditDate was overly complicated, but not sure about the file name format

        Dim sDate As String
        Dim auditDate As Date
        
        
        'Loop through each SOP audit file
        
        For Each ofile In oFiles
            'Strip audit date out of filename and trim off the file extension
            sDate = Split(ofile.Name, "-")(3)
            auditDate = DateSerial(Right(sDate, 4), Left(sDate, 2), Mid(sDate, 3, 2))
    
    ---------------------------------------------------------------------------------------------------------------------

    Paul


    Remember: Tell us WHAT you want to do, not HOW you think you want to do it

    1. Use [CODE] ....[/CODE ] Tags for readability
    [CODE]PasteYourCodeHere[/CODE ] -- (or paste your code, select it, click [#] button)
    2. Upload an example
    Go Advanced / Attachments - Manage Attachments / Add Files / Select Files / Select the file(s) / Upload Files / Done
    3. Mark the thread as [Solved] when you have an answer
    Thread Tools (on the top right corner, above the first message)
    4. Read the Forum FAQ, especially the part about cross-posting in other forums
    http://www.vbaexpress.com/forum/faq...._new_faq_item3

  11. #11
    VBAX Regular
    Joined
    Jul 2019
    Posts
    51
    Location
    Quote Originally Posted by Paul_Hossler View Post
    Minor tweaks to consider

    You could Dim auditDate one time

    I think getting the auditDate was overly complicated, but not sure about the file name format

        Dim sDate As String
        Dim auditDate As Date
        
        
        'Loop through each SOP audit file
        
        For Each ofile In oFiles
            'Strip audit date out of filename and trim off the file extension
            sDate = Split(ofile.Name, "-")(3)
            auditDate = DateSerial(Right(sDate, 4), Left(sDate, 2), Mid(sDate, 3, 2))
    
    I tried changing my code over like you suggested on the auditDate part...I got a type mismatch error.

    Also, I figured I go ahead and post my whole code so you can see how it looks now. My first vba project...it's slow but I'm proud of it!

    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
                Dim sDate As String
                Dim auditDate As Date
                
                'Loop through each SOP audit file
                For Each oFile In oFiles
                    'Strip audit date out of filename and trim off the file extension
                    sDate = Split(oFile.Name, "-")(3)
                    auditDate = DateSerial(Right(sDate, 4), Left(sDate, 2), Mid(sDate, 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

  12. #12
    VBAX Sage
    Joined
    Apr 2007
    Location
    United States
    Posts
    8,711
    Location
    Quote Originally Posted by mongoose View Post
    I tried changing my code over like you suggested on the auditDate part...I got a type mismatch error.

    Also, I figured I go ahead and post my whole code so you can see how it looks now. My first vba project...it's slow but I'm proud of it!
    1. Probably because my guess at the file format was wrong

    2. Working is more important that Fast
    ---------------------------------------------------------------------------------------------------------------------

    Paul


    Remember: Tell us WHAT you want to do, not HOW you think you want to do it

    1. Use [CODE] ....[/CODE ] Tags for readability
    [CODE]PasteYourCodeHere[/CODE ] -- (or paste your code, select it, click [#] button)
    2. Upload an example
    Go Advanced / Attachments - Manage Attachments / Add Files / Select Files / Select the file(s) / Upload Files / Done
    3. Mark the thread as [Solved] when you have an answer
    Thread Tools (on the top right corner, above the first message)
    4. Read the Forum FAQ, especially the part about cross-posting in other forums
    http://www.vbaexpress.com/forum/faq...._new_faq_item3

  13. #13
    VBAX Regular
    Joined
    Jul 2019
    Posts
    51
    Location
    Quote Originally Posted by Paul_Hossler View Post
    1. Probably because my guess at the file format was wrong

    2. Working is more important that Fast
    Ya, the file extension was hanging on to the end of the string. I fixed it.

    Offthelip's, suggestion I have working after some modification except it is writing to just the first sheet. BUT, I do think it may be a little faster...

    Here's the code...
    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 arrSOPID As Variant
                Dim cel As Range
                Dim myStr As String
                Dim monthCol As Long
                Dim x As Long
                
                'Loop through each SOP audit file
                For Each oFile In oFiles
                    'Strip audit date out of filename and trim off the file extension
                    Dim sDate: sDate = Left(Split(oFile.Name, "-")(3), 8)
                    Dim auditDate As Date
                    auditDate = CDate(DateSerial(Right(sDate, 4), Left(sDate, 2), Mid(sDate, 3, 2)))
                    
                    ' find last row of active sheet
                    Dim lastrow: lastrow = Cells(Rows.Count, "A").End(xlUp).Row
                    ' load column A into variant array
                    arrSOPID = Range(Cells(1, 1), Cells(lastrow, 1))
                    
                    
                    'Loop through all SOP IDs stored in COL A
                    For x = 1 To lastrow
                        myStr = arrSOPID(x, 1)
                        'See if SOP ID in COL A matches SOP ID in Audit file name
                        If Trim(RemoveLeadingZeroes(Split(oFile.Name, "-")(2))) = Trim(myStr) Then
                            'Insert link to audit, change background color, etc of selected cell
                             ' cvalculate column to putthe link in
                            monthCol = 4 + Month(auditDate)
                            
                            With ActiveSheet
                                .Hyperlinks.Add Anchor:=.Range(Cells(x, monthCol), Cells(x, monthCol)), _
                                            Address:=oFile.Path, _
                                            TextToDisplay:="X"
                            End With
                        End If
                    Next x                                 
                Next oFile
                
                'Autosize columns to best fit inserted data
                .Columns("A:P").AutoFit
            End With
        Next i
    End Sub
    Also, is there a better way to do this part? Do you guys think it is slowing things down?
    '   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
    Thank you to everyone.
    Last edited by mongoose; 07-30-2019 at 06:38 AM.

  14. #14
    VBAX Expert
    Joined
    May 2016
    Posts
    604
    Location
    The answer is yes there is. try to minimise the number of times you access the worksheet, you are writing 16 cells individually on every sheet.
    I would do this by loading a two dimensional Variant array with the constants (once) and then writing all 16 cells to the workhseet with a single access by writing directly to the whole range, this is slightly slower than writing one cell but much faster than writng 16 cells
       Dim ws As Worksheet   
    aar = Array("SOP ID", "Dept", "SOP TITLE", "LANG", "JAN", "FEB", "MAR", "APR", "MAY", "JUN", "JUL", "AUG", "SEP", "OCT", "NOV", "DEC")
       Dim Vararray(1 To 1, 1 To 16)
       For i = 1 To 16
       Vararray(1, i) = aar(i - 1)
       Next i
        For Each ws In ThisWorkbook.Worksheets
            ws.Cells.ClearContents
            ws.Cells.Interior.Color = xlNone
            ws.Range("A1:P1") = Vararray
            ws.Range("A1:P1").Font.Color = vbBlack
            ws.Range("A1:P1").Font.Bold = True
            ws.Range("A1:P1").Font.Underline = False
        Next ws

  15. #15
    VBAX Sage
    Joined
    Apr 2007
    Location
    United States
    Posts
    8,711
    Location
    I don't think that any possible performance improvements will be perceptible to the user, but this is a another version to consider


    Option Explicit
    
    Sub test()
        Dim aar As Variant
        Dim i As Long
        
        aar = Array("SOP ID", "Dept", "SOP TITLE", "LANG", "JAN", "FEB", "MAR", "APR", "MAY", "JUN", "JUL", "AUG", "SEP", "OCT", "NOV", "DEC")
        
        With Worksheets(1).Cells(1, 1).Resize(1, UBound(aar) + 1)
            .ClearContents
            .Value = Application.WorksheetFunction.Transpose(Application.WorksheetFunction.Transpose(aar))
            .Interior.Color = xlNone
            .Font.Color = vbBlack
            .Font.Bold = True
            .Font.Underline = False
            .Copy
        End With
        
        For i = 2 To Worksheets.Count
            With Worksheets(i)
                .Cells.ClearContents
                Worksheets(1).Cells(1, 1).Resize(1, UBound(aar) + 1).Copy .Cells(1, 1)
            End With
        Next i
    End Sub
    Last edited by Paul_Hossler; 07-30-2019 at 06:38 PM.
    ---------------------------------------------------------------------------------------------------------------------

    Paul


    Remember: Tell us WHAT you want to do, not HOW you think you want to do it

    1. Use [CODE] ....[/CODE ] Tags for readability
    [CODE]PasteYourCodeHere[/CODE ] -- (or paste your code, select it, click [#] button)
    2. Upload an example
    Go Advanced / Attachments - Manage Attachments / Add Files / Select Files / Select the file(s) / Upload Files / Done
    3. Mark the thread as [Solved] when you have an answer
    Thread Tools (on the top right corner, above the first message)
    4. Read the Forum FAQ, especially the part about cross-posting in other forums
    http://www.vbaexpress.com/forum/faq...._new_faq_item3

  16. #16
    VBAX Expert
    Joined
    May 2016
    Posts
    604
    Location
    I don't think that any possible performance improvements will be perceptible to the user, but this is a another version to consider
    I do agree with you, however learning how to use variant arrays is one of the easiest ways of learning how to write speedy VBA, which was what I was trying to demonstrate. In this case not particularly useful but in many case of copying it can make a huge difference,

  17. #17
    VBAX Sage
    Joined
    Apr 2007
    Location
    United States
    Posts
    8,711
    Location
    Quote Originally Posted by offthelip View Post
    I do agree with you, however learning how to use variant arrays is one of the easiest ways of learning how to write speedy VBA, which was what I was trying to demonstrate. In this case not particularly useful but in many case of copying it can make a huge difference,

    And I agree with you -- mostly

    I think it's even more important to learn to write read-able, simple code

    Rightly or Wrongly, I normally only read a WS range into an array if I'm computing many times and need the numbers, and write it back if something changed ( = my very personal style)

    Since you can't format an array, many times it's just cleaner ( = again IMO) to use the WS range


    There's been many discussions here about using arrays vs. cells, but I think it comes down to specific circumstances
    ---------------------------------------------------------------------------------------------------------------------

    Paul


    Remember: Tell us WHAT you want to do, not HOW you think you want to do it

    1. Use [CODE] ....[/CODE ] Tags for readability
    [CODE]PasteYourCodeHere[/CODE ] -- (or paste your code, select it, click [#] button)
    2. Upload an example
    Go Advanced / Attachments - Manage Attachments / Add Files / Select Files / Select the file(s) / Upload Files / Done
    3. Mark the thread as [Solved] when you have an answer
    Thread Tools (on the top right corner, above the first message)
    4. Read the Forum FAQ, especially the part about cross-posting in other forums
    http://www.vbaexpress.com/forum/faq...._new_faq_item3

  18. #18
    VBAX Regular
    Joined
    Jul 2019
    Posts
    51
    Location
    I'm working on implementing the method you are both speaking of. Even if there isn't a speed gain, I want to do it it just for the sake of learning. Speaking of arrays....I am having a lot of trouble working with them and wish I found some material that was more useful than what I've come across thus far.

    Specifically, converting this section of code to how Offthelip suggested....

                '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 sDate: sDate = Left(Split(oFile.Name, "-")(3), 8)
                    Dim auditDate As Date
                    auditDate = CDate(DateSerial(Right(sDate, 4), Left(sDate, 2), Mid(sDate, 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
    Here's my unsuccessful attempt to implement his suggestion...

    'Store cells in COL A that have values as a range
                Dim arrSOPID As Variant
                Dim cel As Range
                Dim myStr As String
                Dim monthCol As Long
                Dim x As Long
                
                'Loop through each SOP audit file
                For Each oFile In oFiles
                    'Strip audit date out of filename and trim off the file extension
                    Dim sDate: sDate = Left(Split(oFile.Name, "-")(3), 8)
                    Dim auditDate As Date
                    auditDate = CDate(DateSerial(Right(sDate, 4), Left(sDate, 2), Mid(sDate, 3, 2)))
                    
                    ' find last row of active sheet
                    Dim lastrow: lastrow = Cells(Rows.Count, "A").End(xlUp).Row
                    ' load column A into variant array
                    arrSOPID = Range(Cells(1, 1), Cells(lastrow, 1))
                    
                    
                    'Loop through all SOP IDs stored in COL A
                    For x = 1 To lastrow
                        myStr = arrSOPID(x, 1)
                        'See if SOP ID in COL A matches SOP ID in Audit file name
                        If Trim(RemoveLeadingZeroes(Split(oFile.Name, "-")(2))) = Trim(myStr) Then
                            'Insert link to audit, change background color, etc of selected cell
                             ' cvalculate column to putthe link in
                            monthCol = 4 + Month(auditDate)
                            
                            With ActiveSheet
                                .Hyperlinks.Add Anchor:=.Range(Cells(x, monthCol), Cells(x, monthCol)), _
                                            Address:=oFile.Path, _
                                            TextToDisplay:="X"
                            End With
                        End If
                    Next x
                    
                Next oFile
    It was semi-functional after I overcome one barrier after another. Then, it seemed to be only charting them out over one sheet instead of distributing it among the correct sheets. Also, I had a problem trying to do this for the background color etc. I was getting an error with that and couldn't figure out what I was doing wrong.

                            With ActiveSheet
                                .Hyperlinks.Add Anchor:=.Range(Cells(x, monthCol), Cells(x, monthCol)), _
                                            Address:=oFile.Path, _
                                            TextToDisplay:="X"
                                .Interior.Color = RGB(34, 139, 34)
                                .Font.Color = vbBlack
                                .Font.Bold = True
                            End With
    Just an update for you all. All the help I've received from you all and the invaluable discussion is bearing fruit. Here's my application so far. I still have a lot more to learn.

    ss11.JPG

  19. #19
    VBAX Regular
    Joined
    Jul 2019
    Posts
    51
    Location
    Ok, here is one improvement.

        'Clear Worksheets, insert column headings w/formatting
        Dim ws As Worksheet
        Dim headings As Variant
        headings = Array("SOP ID", "DEPT", "SOP TITLE", "LANG", "JAN", "FEB", "MAR", "APR", "MAY", _
                         "JUN", "JUL", "AUG", "SEP", "OCT", "NOV", "DEC", "GENERATE AUDIT")
        
        For Each ws In ThisWorkbook.Worksheets
            ws.Cells.ClearContents
            ws.Cells.Interior.Color = xlNone
            With ws.Range("A1:Q1")
                .Value = headings
                .Font.Color = vbBlack
                .Font.Bold = True
                .Font.Underline = False
            End With
        Next ws
    Works good. I do think there was a slight performance gain. Really want to tackle this part next...my curiosity is killing me as to what I am doing wrong when trying to convert it to using an array. Also, need to modify my switch because some of the dept codes could be assigned to multiple depts. Which would mean putting in a loop but I wonder how big of a hit in speed I'll take from doing that.

  20. #20
    VBAX Sage
    Joined
    Apr 2007
    Location
    United States
    Posts
    8,711
    Location
    I'm working on implementing the method you are both speaking of. Even if there isn't a speed gain, I want to do it it just for the sake of learning. Speaking of arrays....I am having a lot of trouble working with them and wish I found some material that was more useful than what I've come across thus far.
    http://www.snb-vba.eu/VBA_Arrays_en.html


    https://bytecomb.com/arrays-in-vba-part-1-types-of-arrays/


    Some references

    ---------------------------------------------------------------------------------------------------------------------

    Paul


    Remember: Tell us WHAT you want to do, not HOW you think you want to do it

    1. Use [CODE] ....[/CODE ] Tags for readability
    [CODE]PasteYourCodeHere[/CODE ] -- (or paste your code, select it, click [#] button)
    2. Upload an example
    Go Advanced / Attachments - Manage Attachments / Add Files / Select Files / Select the file(s) / Upload Files / Done
    3. Mark the thread as [Solved] when you have an answer
    Thread Tools (on the top right corner, above the first message)
    4. Read the Forum FAQ, especially the part about cross-posting in other forums
    http://www.vbaexpress.com/forum/faq...._new_faq_item3

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •