how to store files from a folder into an array and then loop through the array skipping some files dependent on a file's name

J

jono_oh

New Member
Joined
Sep 24, 2021
Messages
12
Office Version
  1. 2016
Platform
  1. Windows
Hello all,

I am trying to develop a macro that is able to loop through a folder and depending on the files files name, opens the file and copy/pastes information from the opened workbook to thisworkbook. I have found that this macro runs, however it misses out some folders despite satisfying the appropriate conditions. I believe the issue is arising from the DIR function but unsure why

VBA Code: 
Sub LoopAllFilesInAFolder()

'This sub loops through all files in the main folder (all files from the sharepoint)

'Defining dimensions from the health assessments that are required:

Dim Spreddie As Variant
Dim PDU, ProjectName, ProjectRef, DemandRef, DeliveryMgr, AssessmentDate, AssessmentMonth, TShirtSize, AssessmentScore As String
Dim Resizerange As String

'Defining the dimension that are used to create the loops:
'R is the counter for the rows of the collated worksheet (Health Assessment Collated workbook)
'Projc is the project counter for the number of rows in the projects worksheet (Health Assessment Collated workbook)
'I is...
'J is...

Dim R, Projc, I, J As Integer
Dim Question(17) As Variant
Dim Rating(17) As Variant
Dim Score(17) As Variant
Dim Notes(17) As Variant
Dim secAutomation As MsoAutomationSecurity
Dim wbSource As String

'Dimensions created for the Name Ranges/ Table names in Excel

Dim oSheetName As Worksheet
Dim sTableName As String
Dim loTable As ListObject
   
'wbSource is the variable used to store the name of the Health assessment collated sheet at this point
wbSource = ActiveWorkbook.Name

Question(1) = "ARA/TRA Compliant?"
Question(2) = "Impact on TS BAU considered?"
Question(3) = "TS Assurance teams engaged?"
Question(4) = "Live Support Model considered?"
Question(5) = "OCM Exists?"
Question(6) = "ITSCM considered?"
Question(7) = "OPH Whole Life costs considered?"
Question(8) = "AWS/AZure Whole Life costs considered?"
Question(9) = "Network Impact and Whole Life costs considered?"
Question(10) = "Software Costs/Renewals considered?"
Question(11) = "Device Costs considered?"
Question(12) = "Application Packaging considered?"
Question(13) = "Accessibility Needs considered?"
Question(14) = "Collaboration Software considered?"
Question(15) = "Security/IT Health Checks considered?"
Question(16) = "Standard PUAM Model to be used?"
Question(17) = "Decommissions included in scope?"

'Setting initial values for the counters
R = 1
Projc = 1

'Clears the "Projects" and "Collated" worksheets of the Health Assessment Collated workbook
Worksheets("Projects").Range("A2:I5000").Formula = " "
Worksheets("Collated").Range("A2:N5000").Formula = " "

'Macro Performance Optimisation Actions
Application.DisplayAlerts = False
Application.ScreenUpdating = False

'Set Spreadie to the File Path of Health assessment Collated workbook:
Spreddie = Dir(Application.ActiveWorkbook.Path & "\")

'Macro Performance Optimisation Actions
Application.EnableEvents = False
secAutomation = Application.AutomationSecurity
Application.AutomationSecurity = msoAutomationSecurityForceDisable

'Setting up a while loop
'while Spreddie is not empty,
'if it has TSP at the start of its name
'AND does not have "Blank Template" in its name then open the workbook (read only)
'Selects the Assessment sheet of Spreddie
'Stores the values from the workbook under variable names (PDU, ProjectName etc)
'Closes the workbook
'Selects the Health Assessment Collated Workbook
'Selects the Projects Worksheet
While Spreddie <> ""

    If InStr(1, Spreddie, "TSP") > 0 And InStr(1, Spreddie, "Blank Template") = 0 Then
        
       
        Workbooks.Open Application.ActiveWorkbook.Path & "\" & Spreddie, ReadOnly:=True
       
      
        Windows(Spreddie).Activate
        Sheets("Assessment").Select
        PDU = Worksheets("Assessment").Cells(2, 3)
        ProjectName = Worksheets("Assessment").Cells(3, 3)
        ProjectRef = Worksheets("Assessment").Cells(4, 3)
        DemandRef = Worksheets("Assessment").Cells(5, 3)
        DeliveryMgr = Worksheets("Assessment").Cells(6, 3)
        AssessmentDate = Worksheets("Assessment").Cells(7, 3)
        AssessmentMonth = Format(AssessmentDate, "YYYY/MM")
        TShirtSize = Worksheets("Assessment").Cells(8, 3)
        AssessmentScore = Worksheets("Assessment").Cells(8, 7)
        Rating(1) = Worksheets("Assessment").Cells(10, 3)
        Score(1) = Worksheets("Assessment").Cells(10, 5)
        Notes(1) = Worksheets("Assessment").Cells(10, 6)
        Rating(2) = Worksheets("Assessment").Cells(11, 3)
        Score(2) = Worksheets("Assessment").Cells(11, 5)
        Notes(2) = Worksheets("Assessment").Cells(11, 6)
        Rating(3) = Worksheets("Assessment").Cells(12, 3)
        Score(3) = Worksheets("Assessment").Cells(12, 5)
        Notes(3) = Worksheets("Assessment").Cells(12, 6)
        Rating(4) = Worksheets("Assessment").Cells(13, 3)
        Score(4) = Worksheets("Assessment").Cells(13, 5)
        Notes(4) = Worksheets("Assessment").Cells(13, 6)
        Rating(5) = Worksheets("Assessment").Cells(14, 3)
        Score(5) = Worksheets("Assessment").Cells(14, 5)
        Notes(5) = Worksheets("Assessment").Cells(14, 6)
        Rating(6) = Worksheets("Assessment").Cells(15, 3)
        Score(6) = Worksheets("Assessment").Cells(15, 5)
        Notes(6) = Worksheets("Assessment").Cells(15, 6)
        Rating(7) = Worksheets("Assessment").Cells(16, 3)
        Score(7) = Worksheets("Assessment").Cells(16, 5)
        Notes(7) = Worksheets("Assessment").Cells(16, 6)
        Rating(8) = Worksheets("Assessment").Cells(17, 3)
        Score(8) = Worksheets("Assessment").Cells(17, 5)
        Notes(8) = Worksheets("Assessment").Cells(17, 6)
        Rating(9) = Worksheets("Assessment").Cells(18, 3)
        Score(9) = Worksheets("Assessment").Cells(18, 5)
        Notes(9) = Worksheets("Assessment").Cells(18, 6)
        Rating(10) = Worksheets("Assessment").Cells(19, 3)
        Score(10) = Worksheets("Assessment").Cells(19, 5)
        Notes(10) = Worksheets("Assessment").Cells(19, 6)
        Rating(11) = Worksheets("Assessment").Cells(20, 3)
        Score(11) = Worksheets("Assessment").Cells(20, 5)
        Notes(11) = Worksheets("Assessment").Cells(20, 6)
        Rating(12) = Worksheets("Assessment").Cells(21, 3)
        Score(12) = Worksheets("Assessment").Cells(21, 5)
        Notes(12) = Worksheets("Assessment").Cells(21, 6)
        Rating(13) = Worksheets("Assessment").Cells(22, 3)
        Score(13) = Worksheets("Assessment").Cells(22, 5)
        Notes(13) = Worksheets("Assessment").Cells(22, 6)
        Rating(14) = Worksheets("Assessment").Cells(23, 3)
        Score(14) = Worksheets("Assessment").Cells(23, 5)
        Notes(14) = Worksheets("Assessment").Cells(23, 6)
        Rating(15) = Worksheets("Assessment").Cells(24, 3)
        Score(15) = Worksheets("Assessment").Cells(24, 5)
        Notes(15) = Worksheets("Assessment").Cells(24, 6)
        Rating(16) = Worksheets("Assessment").Cells(25, 3)
        Score(16) = Worksheets("Assessment").Cells(25, 5)
        Notes(16) = Worksheets("Assessment").Cells(25, 6)
        Rating(17) = Worksheets("Assessment").Cells(26, 3)
        Score(17) = Worksheets("Assessment").Cells(26, 5)
        Notes(17) = Worksheets("Assessment").Cells(26, 6)

'Closes the given Health Assessment workbook
        Workbooks(Spreddie).Close
   
'Selects the Collated workbook, and then selects the projects tab
'Increases the Project counter (Projc) so that the info stored above goes to a new line
'Pastes stored info into correct cells
        Windows(wbSource).Activate
        Sheets("Projects").Select
        Projc = Projc + 1
        Worksheets("Projects").Cells(Projc, 1).Value = PDU
        Worksheets("Projects").Cells(Projc, 2).Value = ProjectName
        Worksheets("Projects").Cells(Projc, 3).Value = ProjectRef
        Worksheets("Projects").Cells(Projc, 4).Value = DemandRef
        Worksheets("Projects").Cells(Projc, 5).Value = DeliveryMgr
        Worksheets("Projects").Cells(Projc, 6).Value = AssessmentDate
        Worksheets("Projects").Cells(Projc, 7).Value = AssessmentMonth
        Worksheets("Projects").Cells(Projc, 8).Value = TShirtSize
        Worksheets("Projects").Cells(Projc, 9).Value = AssessmentScore
       
'Selects the Collated worksheet of the Health Assessment Collated Workbook
        Sheets("Collated").Select
       
'Sets the "QCT" counter value,
'while this counter is less than 18 (something to do with having 17 Questions?)
'Increase R by 1
'Paste stored variables into designated cells
'Then increase QCT by 1
        QCT = 1
        While QCT < 18
            R = R + 1
            Worksheets("Collated").Cells(R, 1).Value = PDU
            Worksheets("Collated").Cells(R, 2).Value = ProjectName
            Worksheets("Collated").Cells(R, 3).Value = ProjectRef
            Worksheets("Collated").Cells(R, 4).Value = DemandRef
            Worksheets("Collated").Cells(R, 5).Value = DeliveryMgr
            Worksheets("Collated").Cells(R, 6).Value = AssessmentDate
            Worksheets("Collated").Cells(R, 7).Value = AssessmentMonth
            Worksheets("Collated").Cells(R, 8).Value = TShirtSize
            Worksheets("Collated").Cells(R, 9).Value = AssessmentScore
            Worksheets("Collated").Cells(R, 10).Value = QCT
            Worksheets("Collated").Cells(R, 11).Value = Question(QCT)
            Worksheets("Collated").Cells(R, 12).Value = Rating(QCT)
            Worksheets("Collated").Cells(R, 13).Value = Score(QCT)
            Worksheets("Collated").Cells(R, 14).Value = Notes(QCT)
       
            QCT = QCT + 1
        Wend

'Above ends the While QCT<18 loop
'Below ends the main While If loop
       
    End If
    'Set the fileName to the next file
    Spreddie = Dir
   
   
Wend

Application.AutomationSecurity = secAutomation
Application.EnableEvents = True
Application.ScreenUpdating = True



sTableName = "Projects"
Set oSheetName = Sheets("Projects")
   
'Define Table Object
Set loTable = oSheetName.ListObjects(sTableName)

Resizerange = "A1:I" & Projc
loTable.Resize Range(Resizerange)
 
Range(Resizerange).WrapText = False
Range(Resizerange).VerticalAlignment = xlTop




'With ActiveSheet.Sort
'    .SortFields.Add Key:=Range("A1"), Order:=xlAscending
'    .SortFields.Add Key:=Range("B1"), Order:=xlAscending
'    .SortFields.Add Key:=Range("C1"), Order:=xlAscending
'    .SortFields.Add Key:=Range("D1"), Order:=xlAscending
'    .SortFields.Add Key:=Range("E1"), Order:=xlAscending
'    .SortFields.Add Key:=Range("F1"), Order:=xlAscending
'    .SortFields.Add Key:=Range("G1"), Order:=xlAscending
'    .SortFields.Add Key:=Range("H1"), Order:=xlAscending
'    .SetRange Range("A1:N5000")
'    .Header = xlYes
'    .Apply
' End With
Sheets("Projects").Select
sTableName = "Collated"
Set oSheetName = Sheets("Collated")
   
'Define Table Object
Set loTable = oSheetName.ListObjects(sTableName)

Resizerange = "A1:N" & R
loTable.Resize Range(Resizerange)
 
Range(Resizerange).WrapText = False
Range(Resizerange).VerticalAlignment = xlTop

' With ActiveSheet.Sort
'    .SortFields.Add Key:=Range("A1"), Order:=xlAscending
'    .SortFields.Add Key:=Range("B1"), Order:=xlAscending
'    .SortFields.Add Key:=Range("C1"), Order:=xlAscending
'    .SortFields.Add Key:=Range("D1"), Order:=xlAscending
'    .SortFields.Add Key:=Range("E1"), Order:=xlAscending
'    .SortFields.Add Key:=Range("F1"), Order:=xlAscending
'    .SortFields.Add Key:=Range("G1"), Order:=xlAscending
'    .SortFields.Add Key:=Range("H1"), Order:=xlAscending
'    .SetRange Range("A1:I5000")
'    .Header = xlYes
'    .Apply
' End With
ThisWorkbook.RefreshAll

Application.DisplayAlerts = True
Sheets("Collated").Select

MsgBox "Workbook Updated", vbOKOnly, "Message"

End Sub
 
Last edited by a moderator:

Excel Facts

Copy formula down without changing references
If you have =SUM(F2:F49) in F50; type Alt+' in F51 to copy =SUM(F2:F49) to F51, leaving the formula in edit mode. Change SUM to COUNT.
Sort by date Sort by votes
Wow! That is a lot of code screaming to be shortened!

One thing I noticed, thanks to the commenting of the code :

VBA Code: 
'while Spreddie is not empty,
'if it has TSP at the start of its name   ' <---
'AND does not have "Blank Template" in its name then open the workbook (read only)   ' <---
'Selects the Assessment sheet of Spreddie
'Stores the values from the workbook under variable names (PDU, ProjectName etc)
'Closes the workbook
'Selects the Health Assessment Collated Workbook
'Selects the Projects Worksheet
While Spreddie <> ""

    If InStr(1, Spreddie, "TSP") > 0 And InStr(1, Spreddie, "Blank Template") = 0 Then

That last line of code doesn't do what the comments say. That last line of code actually checks any portion of the file name, not just the start of the file name.

So basically it verifies "TSP" is somewhere in the filename & "Blank Template" is nowhere in the filename.
 
Last edited:
Upvote 0
johnnyL said:
Wow! That is a lot of code screaming to be shortened!

One thing I noticed, thanks to the commenting of the code :

VBA Code: 
'while Spreddie is not empty,
'if it has TSP at the start of its name   ' <---
'AND does not have "Blank Template" in its name then open the workbook (read only)   ' <---
'Selects the Assessment sheet of Spreddie
'Stores the values from the workbook under variable names (PDU, ProjectName etc)
'Closes the workbook
'Selects the Health Assessment Collated Workbook
'Selects the Projects Worksheet
While Spreddie <> ""

    If InStr(1, Spreddie, "TSP") > 0 And InStr(1, Spreddie, "Blank Template") = 0 Then

That last line of code doesn't do what the comments say. That last line of code actually checks any portion of the file name, not just the start of the file name.

So basically it verifies "TSP" is somewhere in the filename & "Blank Template" is nowhere in the filename.
Click to expand...
Thank you for your help JohnnyL however that was not the main issue I was facing- I have managed to get the macro to work now so will post the answers below
 
Upvote 0
VBA Code: 
Sub get_latest_health_assessments()
'Gathers the names of all files found within my local version of the archive folder

'An object represents an element of an application, such as a worksheet, a cell, a chart, a form, or a report.
'In Visual Basic code, you must identify an object before you can apply one of the object's methods or change
'the value of one of its properties.

Dim oFSO As Object
Dim oFolder As Object
Dim oFile As Object
Dim i As Integer
Dim sFilePath As String

sFilePath = Application.ActiveWorkbook.Path

'Creates and returns a reference to an ActiveX object.
'An ActiveX object is an object that is exposed to other applications
'or programming tools through Automation interfaces.

'FileSystemObject provides access to a computer's file system.
'Scripting?
'GetFolder returns a Folder object corresponding to the folder in a specified path.
'Syntax for this is object.GetFolder (folderspec)
'object here is always the name of a FileSystemObject.
'folderspec is the path (absolute or relative) to a specific folder.

Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oFolder = oFSO.GetFolder(sFilePath)
'This workbook is stored in the main folder (ie not archive)

Dim PDU As String
Dim ProjectName As String
Dim ProjectRef As String
Dim DemandRef As String
Dim DeliveryMgr As String
Dim AssessmentDate As String
Dim AssessmentMonth As String
Dim TShirtSize As String
Dim AssessmentScore As String
Dim Resizerange As String

Dim Question(17) As Variant
Dim Rating(17) As Variant
Dim Score(17) As Variant
Dim Notes(17) As Variant
Dim R, Projc, QCT As Integer

Dim secAutomation As MsoAutomationSecurity
Dim wbSource As String
wbSource = ActiveWorkbook.Name

R = 1
Projc = 1

Worksheets("Projects").Range("A2:I5000").Formula = " "
Worksheets("Collated").Range("A2:N5000").Formula = " "

Question(1) = "ARA/TRA Compliant?"
Question(2) = "Impact on TS BAU considered?"
Question(3) = "TS Assurance teams engaged?"
Question(4) = "Live Support Model considered?"
Question(5) = "OCM Exists?"
Question(6) = "ITSCM considered?"
Question(7) = "OPH Whole Life costs considered?"
Question(8) = "AWS/AZure Whole Life costs considered?"
Question(9) = "Network Impact and Whole Life costs considered?"
Question(10) = "Software Costs/Renewals considered?"
Question(11) = "Device Costs considered?"
Question(12) = "Application Packaging considered?"
Question(13) = "Accessibility Needs considered?"
Question(14) = "Collaboration Software considered?"
Question(15) = "Security/IT Health Checks considered?"
Question(16) = "Standard PUAM Model to be used?"
Question(17) = "Decommissions included in scope?"

i = 2

'Macro Performance Optimisation Actions
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Application.EnableEvents = False
secAutomation = Application.AutomationSecurity
Application.AutomationSecurity = msoAutomationSecurityForceDisable

For Each oFile In oFolder.Files
'    ArchiveFolderArray(i) = oFile.Name
'    Sheet1.Cells(i, 1).Value = oFile.Name
    'i = i + 1
    If InStr(1, oFile.Name, "TSP") > 0 And InStr(1, oFile.Name, "Blank Template") = 0 Then
        Workbooks.Open oFile, ReadOnly:=True
        Windows(oFile.Name).Activate
        Sheets("Assessment").Select
        PDU = Worksheets("Assessment").Cells(2, 3)
        ProjectName = Worksheets("Assessment").Cells(3, 3)
        ProjectRef = Worksheets("Assessment").Cells(4, 3)
        DemandRef = Worksheets("Assessment").Cells(5, 3)
        DeliveryMgr = Worksheets("Assessment").Cells(6, 3)
        AssessmentDate = Worksheets("Assessment").Cells(7, 3)
        AssessmentMonth = Format(AssessmentDate, "YYYY/MM")
        TShirtSize = Worksheets("Assessment").Cells(8, 3)
        AssessmentScore = Worksheets("Assessment").Cells(8, 7)
        Rating(1) = Worksheets("Assessment").Cells(10, 3)
        Score(1) = Worksheets("Assessment").Cells(10, 5)
        Notes(1) = Worksheets("Assessment").Cells(10, 6)
        Rating(2) = Worksheets("Assessment").Cells(11, 3)
        Score(2) = Worksheets("Assessment").Cells(11, 5)
        Notes(2) = Worksheets("Assessment").Cells(11, 6)
        Rating(3) = Worksheets("Assessment").Cells(12, 3)
        Score(3) = Worksheets("Assessment").Cells(12, 5)
        Notes(3) = Worksheets("Assessment").Cells(12, 6)
        Rating(4) = Worksheets("Assessment").Cells(13, 3)
        Score(4) = Worksheets("Assessment").Cells(13, 5)
        Notes(4) = Worksheets("Assessment").Cells(13, 6)
        Rating(5) = Worksheets("Assessment").Cells(14, 3)
        Score(5) = Worksheets("Assessment").Cells(14, 5)
        Notes(5) = Worksheets("Assessment").Cells(14, 6)
        Rating(6) = Worksheets("Assessment").Cells(15, 3)
        Score(6) = Worksheets("Assessment").Cells(15, 5)
        Notes(6) = Worksheets("Assessment").Cells(15, 6)
        Rating(7) = Worksheets("Assessment").Cells(16, 3)
        Score(7) = Worksheets("Assessment").Cells(16, 5)
        Notes(7) = Worksheets("Assessment").Cells(16, 6)
        Rating(8) = Worksheets("Assessment").Cells(17, 3)
        Score(8) = Worksheets("Assessment").Cells(17, 5)
        Notes(8) = Worksheets("Assessment").Cells(17, 6)
        Rating(9) = Worksheets("Assessment").Cells(18, 3)
        Score(9) = Worksheets("Assessment").Cells(18, 5)
        Notes(9) = Worksheets("Assessment").Cells(18, 6)
        Rating(10) = Worksheets("Assessment").Cells(19, 3)
        Score(10) = Worksheets("Assessment").Cells(19, 5)
        Notes(10) = Worksheets("Assessment").Cells(19, 6)
        Rating(11) = Worksheets("Assessment").Cells(20, 3)
        Score(11) = Worksheets("Assessment").Cells(20, 5)
        Notes(11) = Worksheets("Assessment").Cells(20, 6)
        Rating(12) = Worksheets("Assessment").Cells(21, 3)
        Score(12) = Worksheets("Assessment").Cells(21, 5)
        Notes(12) = Worksheets("Assessment").Cells(21, 6)
        Rating(13) = Worksheets("Assessment").Cells(22, 3)
        Score(13) = Worksheets("Assessment").Cells(22, 5)
        Notes(13) = Worksheets("Assessment").Cells(22, 6)
        Rating(14) = Worksheets("Assessment").Cells(23, 3)
        Score(14) = Worksheets("Assessment").Cells(23, 5)
        Notes(14) = Worksheets("Assessment").Cells(23, 6)
        Rating(15) = Worksheets("Assessment").Cells(24, 3)
        Score(15) = Worksheets("Assessment").Cells(24, 5)
        Notes(15) = Worksheets("Assessment").Cells(24, 6)
        Rating(16) = Worksheets("Assessment").Cells(25, 3)
        Score(16) = Worksheets("Assessment").Cells(25, 5)
        Notes(16) = Worksheets("Assessment").Cells(25, 6)
        Rating(17) = Worksheets("Assessment").Cells(26, 3)
        Score(17) = Worksheets("Assessment").Cells(26, 5)
        Notes(17) = Worksheets("Assessment").Cells(26, 6)
        'Closes the given Health Assessment workbook
        Workbooks(oFile.Name).Close
        'Selects the Collated workbook, and then selects the projects tab
        'Increases the Project counter (Projc) so that the info stored above goes to a new line
        'Pastes stored info into correct cells
        Windows(wbSource).Activate
        Sheets("Projects").Select
        Projc = Projc + 1
        Worksheets("Projects").Cells(Projc, 1).Value = PDU
        Worksheets("Projects").Cells(Projc, 2).Value = ProjectName
        Worksheets("Projects").Cells(Projc, 3).Value = ProjectRef
        Worksheets("Projects").Cells(Projc, 4).Value = DemandRef
        Worksheets("Projects").Cells(Projc, 5).Value = DeliveryMgr
        Worksheets("Projects").Cells(Projc, 6).Value = AssessmentDate
        Worksheets("Projects").Cells(Projc, 7).Value = AssessmentMonth
        Worksheets("Projects").Cells(Projc, 8).Value = TShirtSize
        Worksheets("Projects").Cells(Projc, 9).Value = AssessmentScore
       
        Sheets("Collated").Select
       
'Sets the "QCT" counter value,
'while this counter is less than 18 (something to do with having 17 Questions?)
'Increase R by 1
'Paste stored variables into designated cells
'Then increase QCT by 1
        QCT = 1
        While QCT < 18
            R = R + 1
            Worksheets("Collated").Cells(R, 1).Value = PDU
            Worksheets("Collated").Cells(R, 2).Value = ProjectName
            Worksheets("Collated").Cells(R, 3).Value = ProjectRef
            Worksheets("Collated").Cells(R, 4).Value = DemandRef
            Worksheets("Collated").Cells(R, 5).Value = DeliveryMgr
            Worksheets("Collated").Cells(R, 6).Value = AssessmentDate
            Worksheets("Collated").Cells(R, 7).Value = AssessmentMonth
            Worksheets("Collated").Cells(R, 8).Value = TShirtSize
            Worksheets("Collated").Cells(R, 9).Value = AssessmentScore
            Worksheets("Collated").Cells(R, 10).Value = QCT
            Worksheets("Collated").Cells(R, 11).Value = Question(QCT)
            Worksheets("Collated").Cells(R, 12).Value = Rating(QCT)
            Worksheets("Collated").Cells(R, 13).Value = Score(QCT)
            Worksheets("Collated").Cells(R, 14).Value = Notes(QCT)
       
            QCT = QCT + 1
           
        Wend
       
        i = i + 1
       
        Else
        i = i + 1
       
        End If
       
Next oFile

Application.EnableEvents = True
Application.ScreenUpdating = True

sTableName = "Projects"
Set oSheetName = Sheets("Projects")
   
'Define Table Object
Set loTable = oSheetName.ListObjects(sTableName)

Resizerange = "A1:I" & Projc
loTable.Resize Range(Resizerange)
 
Range(Resizerange).WrapText = False
Range(Resizerange).VerticalAlignment = xlTop

'With ActiveSheet.Sort
'    .SortFields.Add Key:=Range("A1"), Order:=xlAscending
'    .SortFields.Add Key:=Range("B1"), Order:=xlAscending
'    .SortFields.Add Key:=Range("C1"), Order:=xlAscending
'    .SortFields.Add Key:=Range("D1"), Order:=xlAscending
'    .SortFields.Add Key:=Range("E1"), Order:=xlAscending
'    .SortFields.Add Key:=Range("F1"), Order:=xlAscending
'    .SortFields.Add Key:=Range("G1"), Order:=xlAscending
'    .SortFields.Add Key:=Range("H1"), Order:=xlAscending
'    .SetRange Range("A1:N5000")
'    .Header = xlYes
'    .Apply
' End With

Sheets("Projects").Select
sTableName = "Collated"
Set oSheetName = Sheets("Collated")
   
'Define Table Object
Set loTable = oSheetName.ListObjects(sTableName)

Resizerange = "A1:N" & R
loTable.Resize Range(Resizerange)
 
Range(Resizerange).WrapText = False
Range(Resizerange).VerticalAlignment = xlTop

' With ActiveSheet.Sort
'    .SortFields.Add Key:=Range("A1"), Order:=xlAscending
'    .SortFields.Add Key:=Range("B1"), Order:=xlAscending
'    .SortFields.Add Key:=Range("C1"), Order:=xlAscending
'    .SortFields.Add Key:=Range("D1"), Order:=xlAscending
'    .SortFields.Add Key:=Range("E1"), Order:=xlAscending
'    .SortFields.Add Key:=Range("F1"), Order:=xlAscending
'    .SortFields.Add Key:=Range("G1"), Order:=xlAscending
'    .SortFields.Add Key:=Range("H1"), Order:=xlAscending
'    .SetRange Range("A1:I5000")
'    .Header = xlYes
'    .Apply
' End With
ThisWorkbook.RefreshAll

Application.DisplayAlerts = True
Sheets("Collated").Select

MsgBox "Workbook Updated", vbOKOnly, "Message"

End Sub


Sub get_archive_health_assessments()
'Gathers the names of all files found within my local version of the archive folder

'An object represents an element of an application, such as a worksheet, a cell, a chart, a form, or a report.
'In Visual Basic code, you must identify an object before you can apply one of the object's methods or change
'the value of one of its properties.

Dim oFSO As Object
Dim oFolder As Object
Dim oFile As Object
Dim i As Integer
Dim sFilePath As String

sFilePath = Application.ActiveWorkbook.Path & "\archive\"

'Creates and returns a reference to an ActiveX object.
'An ActiveX object is an object that is exposed to other applications
'or programming tools through Automation interfaces.

'FileSystemObject provides access to a computer's file system.
'Scripting?
'GetFolder returns a Folder object corresponding to the folder in a specified path.
'Syntax for this is object.GetFolder (folderspec)
'object here is always the name of a FileSystemObject.
'folderspec is the path (absolute or relative) to a specific folder.

Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oFolder = oFSO.GetFolder(sFilePath)
'This workbook is stored in the main folder (ie not archive)

Dim PDU As String
Dim ProjectName As String
Dim ProjectRef As String
Dim DemandRef As String
Dim DeliveryMgr As String
Dim AssessmentDate As String
Dim AssessmentMonth As String
Dim TShirtSize As String
Dim AssessmentScore As String
Dim Resizerange As String

Dim Question(17) As Variant
Dim Rating(17) As Variant
Dim Score(17) As Variant
Dim Notes(17) As Variant
Dim R, Projc, QCT As Integer

Dim secAutomation As MsoAutomationSecurity
Dim wbSource As String
wbSource = ActiveWorkbook.Name

R = 1
Projc = 1

Worksheets("ArchiveProjects").Range("A2:I5000").Formula = " "
Worksheets("ArchiveCollated").Range("A2:N5000").Formula = " "

Question(1) = "ARA/TRA Compliant?"
Question(2) = "Impact on TS BAU considered?"
Question(3) = "TS Assurance teams engaged?"
Question(4) = "Live Support Model considered?"
Question(5) = "OCM Exists?"
Question(6) = "ITSCM considered?"
Question(7) = "OPH Whole Life costs considered?"
Question(8) = "AWS/AZure Whole Life costs considered?"
Question(9) = "Network Impact and Whole Life costs considered?"
Question(10) = "Software Costs/Renewals considered?"
Question(11) = "Device Costs considered?"
Question(12) = "Application Packaging considered?"
Question(13) = "Accessibility Needs considered?"
Question(14) = "Collaboration Software considered?"
Question(15) = "Security/IT Health Checks considered?"
Question(16) = "Standard PUAM Model to be used?"
Question(17) = "Decommissions included in scope?"

i = 2

'Macro Performance Optimisation Actions
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Application.EnableEvents = False
secAutomation = Application.AutomationSecurity
Application.AutomationSecurity = msoAutomationSecurityForceDisable

For Each oFile In oFolder.Files
'    ArchiveFolderArray(i) = oFile.Name
'    Sheet1.Cells(i, 1).Value = oFile.Name
    'i = i + 1
    If InStr(1, oFile.Name, "TSP") > 0 And InStr(1, oFile.Name, "Blank Template") = 0 Then
        Workbooks.Open oFile, ReadOnly:=True
        Windows(oFile.Name).Activate
        Sheets("Assessment").Select
        PDU = Worksheets("Assessment").Cells(2, 3)
        ProjectName = Worksheets("Assessment").Cells(3, 3)
        ProjectRef = Worksheets("Assessment").Cells(4, 3)
        DemandRef = Worksheets("Assessment").Cells(5, 3)
        DeliveryMgr = Worksheets("Assessment").Cells(6, 3)
        AssessmentDate = Worksheets("Assessment").Cells(7, 3)
        AssessmentMonth = Format(AssessmentDate, "YYYY/MM")
        TShirtSize = Worksheets("Assessment").Cells(8, 3)
        AssessmentScore = Worksheets("Assessment").Cells(8, 7)
        Rating(1) = Worksheets("Assessment").Cells(10, 3)
        Score(1) = Worksheets("Assessment").Cells(10, 5)
        Notes(1) = Worksheets("Assessment").Cells(10, 6)
        Rating(2) = Worksheets("Assessment").Cells(11, 3)
        Score(2) = Worksheets("Assessment").Cells(11, 5)
        Notes(2) = Worksheets("Assessment").Cells(11, 6)
        Rating(3) = Worksheets("Assessment").Cells(12, 3)
        Score(3) = Worksheets("Assessment").Cells(12, 5)
        Notes(3) = Worksheets("Assessment").Cells(12, 6)
        Rating(4) = Worksheets("Assessment").Cells(13, 3)
        Score(4) = Worksheets("Assessment").Cells(13, 5)
        Notes(4) = Worksheets("Assessment").Cells(13, 6)
        Rating(5) = Worksheets("Assessment").Cells(14, 3)
        Score(5) = Worksheets("Assessment").Cells(14, 5)
        Notes(5) = Worksheets("Assessment").Cells(14, 6)
        Rating(6) = Worksheets("Assessment").Cells(15, 3)
        Score(6) = Worksheets("Assessment").Cells(15, 5)
        Notes(6) = Worksheets("Assessment").Cells(15, 6)
        Rating(7) = Worksheets("Assessment").Cells(16, 3)
        Score(7) = Worksheets("Assessment").Cells(16, 5)
        Notes(7) = Worksheets("Assessment").Cells(16, 6)
        Rating(8) = Worksheets("Assessment").Cells(17, 3)
        Score(8) = Worksheets("Assessment").Cells(17, 5)
        Notes(8) = Worksheets("Assessment").Cells(17, 6)
        Rating(9) = Worksheets("Assessment").Cells(18, 3)
        Score(9) = Worksheets("Assessment").Cells(18, 5)
        Notes(9) = Worksheets("Assessment").Cells(18, 6)
        Rating(10) = Worksheets("Assessment").Cells(19, 3)
        Score(10) = Worksheets("Assessment").Cells(19, 5)
        Notes(10) = Worksheets("Assessment").Cells(19, 6)
        Rating(11) = Worksheets("Assessment").Cells(20, 3)
        Score(11) = Worksheets("Assessment").Cells(20, 5)
        Notes(11) = Worksheets("Assessment").Cells(20, 6)
        Rating(12) = Worksheets("Assessment").Cells(21, 3)
        Score(12) = Worksheets("Assessment").Cells(21, 5)
        Notes(12) = Worksheets("Assessment").Cells(21, 6)
        Rating(13) = Worksheets("Assessment").Cells(22, 3)
        Score(13) = Worksheets("Assessment").Cells(22, 5)
        Notes(13) = Worksheets("Assessment").Cells(22, 6)
        Rating(14) = Worksheets("Assessment").Cells(23, 3)
        Score(14) = Worksheets("Assessment").Cells(23, 5)
        Notes(14) = Worksheets("Assessment").Cells(23, 6)
        Rating(15) = Worksheets("Assessment").Cells(24, 3)
        Score(15) = Worksheets("Assessment").Cells(24, 5)
        Notes(15) = Worksheets("Assessment").Cells(24, 6)
        Rating(16) = Worksheets("Assessment").Cells(25, 3)
        Score(16) = Worksheets("Assessment").Cells(25, 5)
        Notes(16) = Worksheets("Assessment").Cells(25, 6)
        Rating(17) = Worksheets("Assessment").Cells(26, 3)
        Score(17) = Worksheets("Assessment").Cells(26, 5)
        Notes(17) = Worksheets("Assessment").Cells(26, 6)
        'Closes the given Health Assessment workbook
        Workbooks(oFile.Name).Close
        'Selects the Collated workbook, and then selects the projects tab
        'Increases the Project counter (Projc) so that the info stored above goes to a new line
        'Pastes stored info into correct cells
        Windows(wbSource).Activate
        Sheets("Projects").Select
        Projc = Projc + 1
        Worksheets("ArchiveProjects").Cells(Projc, 1).Value = PDU
        Worksheets("ArchiveProjects").Cells(Projc, 2).Value = ProjectName
        Worksheets("ArchiveProjects").Cells(Projc, 3).Value = ProjectRef
        Worksheets("ArchiveProjects").Cells(Projc, 4).Value = DemandRef
        Worksheets("ArchiveProjects").Cells(Projc, 5).Value = DeliveryMgr
        Worksheets("ArchiveProjects").Cells(Projc, 6).Value = AssessmentDate
        Worksheets("ArchiveProjects").Cells(Projc, 7).Value = AssessmentMonth
        Worksheets("ArchiveProjects").Cells(Projc, 8).Value = TShirtSize
        Worksheets("ArchiveProjects").Cells(Projc, 9).Value = AssessmentScore
       
        Sheets("ArchiveCollated").Select
       
'Sets the "QCT" counter value,
'while this counter is less than 18 (something to do with having 17 Questions?)
'Increase R by 1
'Paste stored variables into designated cells
'Then increase QCT by 1
        QCT = 1
        While QCT < 18
            R = R + 1
            Worksheets("ArchiveCollated").Cells(R, 1).Value = PDU
            Worksheets("ArchiveCollated").Cells(R, 2).Value = ProjectName
            Worksheets("ArchiveCollated").Cells(R, 3).Value = ProjectRef
            Worksheets("ArchiveCollated").Cells(R, 4).Value = DemandRef
            Worksheets("ArchiveCollated").Cells(R, 5).Value = DeliveryMgr
            Worksheets("ArchiveCollated").Cells(R, 6).Value = AssessmentDate
            Worksheets("ArchiveCollated").Cells(R, 7).Value = AssessmentMonth
            Worksheets("ArchiveCollated").Cells(R, 8).Value = TShirtSize
            Worksheets("ArchiveCollated").Cells(R, 9).Value = AssessmentScore
            Worksheets("ArchiveCollated").Cells(R, 10).Value = QCT
            Worksheets("ArchiveCollated").Cells(R, 11).Value = Question(QCT)
            Worksheets("ArchiveCollated").Cells(R, 12).Value = Rating(QCT)
            Worksheets("ArchiveCollated").Cells(R, 13).Value = Score(QCT)
            Worksheets("ArchiveCollated").Cells(R, 14).Value = Notes(QCT)
       
            QCT = QCT + 1
           
        Wend
       
        i = i + 1
       
        Else
        i = i + 1
       
        End If
       
Next oFile

Application.EnableEvents = True
Application.ScreenUpdating = True

sTableName = "ArchiveProjects"
Set oSheetName = Sheets("ArchiveProjects")
   
'Define Table Object
Set loTable = oSheetName.ListObjects(sTableName)

Resizerange = "A1:I" & Projc
loTable.Resize Range(Resizerange)
 
Range(Resizerange).WrapText = False
Range(Resizerange).VerticalAlignment = xlTop

'With ActiveSheet.Sort
'    .SortFields.Add Key:=Range("A1"), Order:=xlAscending
'    .SortFields.Add Key:=Range("B1"), Order:=xlAscending
'    .SortFields.Add Key:=Range("C1"), Order:=xlAscending
'    .SortFields.Add Key:=Range("D1"), Order:=xlAscending
'    .SortFields.Add Key:=Range("E1"), Order:=xlAscending
'    .SortFields.Add Key:=Range("F1"), Order:=xlAscending
'    .SortFields.Add Key:=Range("G1"), Order:=xlAscending
'    .SortFields.Add Key:=Range("H1"), Order:=xlAscending
'    .SetRange Range("A1:N5000")
'    .Header = xlYes
'    .Apply
' End With

Sheets("ArchiveProjects").Select
sTableName = "ArchiveCollated"
Set oSheetName = Sheets("ArchiveCollated")
   
'Define Table Object
Set loTable = oSheetName.ListObjects(sTableName)

Resizerange = "A1:N" & R
loTable.Resize Range(Resizerange)
 
Range(Resizerange).WrapText = False
Range(Resizerange).VerticalAlignment = xlTop

' With ActiveSheet.Sort
'    .SortFields.Add Key:=Range("A1"), Order:=xlAscending
'    .SortFields.Add Key:=Range("B1"), Order:=xlAscending
'    .SortFields.Add Key:=Range("C1"), Order:=xlAscending
'    .SortFields.Add Key:=Range("D1"), Order:=xlAscending
'    .SortFields.Add Key:=Range("E1"), Order:=xlAscending
'    .SortFields.Add Key:=Range("F1"), Order:=xlAscending
'    .SortFields.Add Key:=Range("G1"), Order:=xlAscending
'    .SortFields.Add Key:=Range("H1"), Order:=xlAscending
'    .SetRange Range("A1:I5000")
'    .Header = xlYes
'    .Apply
' End With
ThisWorkbook.RefreshAll

Application.DisplayAlerts = True
Sheets("Collated").Select

MsgBox "Workbook Updated", vbOKOnly, "Message"

End Sub
 
Last edited by a moderator:
Upvote 0
Hello,​
​
to store filenames from a folder to an array you can use my DirList function like in this thread :​
www.mrexcel.com

bring files from folders and subfolders to multiple columns based on folders names

hi I need macro to brings all files from folder and subfolders to multiple columns so my directory isle "C:\Users\mm\Desktop\FILES" it contains many subfolders FILE1 up to FILE 6 and it's increasable and each subfolder contain files are different...
www.mrexcel.com www.mrexcel.com
 
Upvote 0
You must log in or register to reply here.

Similar threads

S
  • Question Question
Excel VBA - Sort & Get Totals - Logic
Replies
4
Views
426
STARL0RD
S
S
  • Solved
Working with multiple Target Ranges in Worksheet Code
Replies
3
Views
774
sspatriots
S
S
  • Question Question
Worksheet Change Event
Replies
2
Views
720
sspatriots
S
S
  • Question Question
Need code that adds multiple new rows to table to include a check box in column "L" for each new row
Replies
0
Views
544
sspatriots
S
M
  • Question Question
Loop through each file in folder and perform an action
Replies
0
Views
601
Monsieur Roo
M

Forum statistics

Threads
1,224,820
Messages
6,181,159
Members
453,021
Latest member
Justyna P

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top