Option Explicit
Sub DoStuff()
' ****************************************************
' Set this line to the path and Parent Folder ...don't forget True at the end of the line
OpenFilesInAllFolders "F:\Excel Test Files\Excel Compile", True
' ****************************************************
Sheets("Sheet1").Activate
Application.ScreenUpdating = False
End Sub
'Summary: Open all files in a single folder or all files in the subfolders of the parent
' folder, Only look at files that begin with PJ.
Sub OpenFilesInAllFolders(ByVal SourceFolderName As String, ByVal IncludeSubfolders As Boolean)
Dim FSO As Object
Dim SourceFolder As Object
Dim subfolder As Object
Dim FileItem As Object
Dim LR As Long
Dim ws As Worksheet
Set ws = Sheets("Sheet1") 'Target Sheet Name
Set FSO = CreateObject("Scripting.FileSystemObject")
Set SourceFolder = FSO.GetFolder(SourceFolderName)
For Each FileItem In SourceFolder.Files
If Not InStr(FileItem.Name, "Master") = 1 _
And Not InStr(FileItem.Name, "~$Master") = 1 _
And InStr(FileItem.Name, "PJ") = 1 _
And InStr(FileItem.Name, ".xlsx") Then
Workbooks.Open SourceFolder & "\" & FileItem.Name
' ActiveSheet.Range("A98").Value = "Compiled" This allows the Script
' To know that the file has been read already, stops any duplications
If Not ActiveSheet.Range("A98").Value = "Compiled" Then
With ws
LR = .Range("A" & .Rows.Count).End(xlUp).Row + 1
.Cells(LR, "A") = ActiveSheet.Range("E12") 'Customer
.Cells(LR, "B") = ActiveSheet.Range("E13") 'Location
.Cells(LR, "C") = ActiveSheet.Range("E14") 'Contact
.Cells(LR, "E") = ActiveSheet.Range("U12") 'Technician
.Cells(LR, "F") = ActiveSheet.Range("U13") 'Chargable
.Cells(LR, "G") = ActiveSheet.Range("G15") 'Machine Type 1
.Cells(LR, "H") = ActiveSheet.Range("G16") 'Serial Number 1
.Cells(LR, "I") = ActiveSheet.Range("G17") 'Hours Run 1
.Cells(LR, "J") = ActiveSheet.Range("N15") 'Machine Type 2
.Cells(LR, "K") = ActiveSheet.Range("N16") 'serial Number 2
.Cells(LR, "L") = ActiveSheet.Range("N17") 'Hours Run 2
.Cells(LR, "M") = ActiveSheet.Range("V15") 'Machine Type 3
.Cells(LR, "N") = ActiveSheet.Range("V16") 'serial Number 3
.Cells(LR, "O") = ActiveSheet.Range("V17") 'Hours Run 3
.Cells(LR, "P") = ActiveSheet.Range("AB15") 'Machine Type 4
.Cells(LR, "Q") = ActiveSheet.Range("AB16") 'serial Number 4
.Cells(LR, "R") = ActiveSheet.Range("AB17") 'Hours Run 4
.Cells(LR, "S") = ActiveSheet.Range("AI15") 'Machine Type 5
.Cells(LR, "T") = ActiveSheet.Range("AI16") 'serial Number 5
.Cells(LR, "U") = ActiveSheet.Range("AI17") 'Hours Run 5
.Cells(LR, "V") = ActiveSheet.Range("I20") 'Reason For Visit
.Cells(LR, "W") = ActiveSheet.Range("A23") 'Line 1 of
.Cells(LR, "X") = ActiveSheet.Range("A24") 'Line 2
.Cells(LR, "Y") = ActiveSheet.Range("A25") 'Line 3
.Cells(LR, "Z") = ActiveSheet.Range("A26") 'Line 4
.Cells(LR, "AA") = ActiveSheet.Range("A27") 'Line 5
.Cells(LR, "AB") = ActiveSheet.Range("A28") 'Line 6
.Cells(LR, "AC") = ActiveSheet.Range("A29") 'Line 7
.Cells(LR, "AD") = ActiveSheet.Range("A30") 'Line 8
.Cells(LR, "AE") = ActiveSheet.Range("A31") 'Line 9
.Cells(LR, "AF") = ActiveSheet.Range("A32") 'Line 10
.Cells(LR, "AG") = ActiveSheet.Range("A33") 'Line 11
.Cells(LR, "AH") = ActiveSheet.Range("A34") 'Line 12
.Cells(LR, "AI") = ActiveSheet.Range("A35") 'Line 13
.Cells(LR, "AJ") = ActiveSheet.Range("A36") 'Line 14
.Cells(LR, "AK") = ActiveSheet.Range("A37") 'Line 15
.Cells(LR, "AL") = ActiveSheet.Range("A67") 'Line 16
.Cells(LR, "AM") = ActiveSheet.Range("A68") 'Line 17
.Cells(LR, "AN") = ActiveSheet.Range("Y50") 'Total Hours Worked
'***********************************************
'Compile Project Numbers at the end of the sheet
'***********************************************
.Cells(LR, "DA") = ActiveSheet.Range("Y10") 'PJ**-0000-0000-00
.Cells(LR, "DB") = ActiveSheet.Range("AB10") 'PJ00-****-0000-00
.Cells(LR, "DC") = ActiveSheet.Range("AG10") 'PJ00-0000-****-00
.Cells(LR, "DD") = ActiveSheet.Range("AL10") 'PJ00-0000-0000-**
ActiveSheet.Range("A98").Value = "Compiled"
'*****************************************************
End With
End If
ActiveWorkbook.Close True
End If
Next FileItem
If IncludeSubfolders Then
For Each subfolder In SourceFolder.SubFolders
OpenFilesInAllFolders subfolder.Path, True
Next subfolder
End If
Set FileItem = Nothing
Set SourceFolder = Nothing
Set FSO = Nothing
End Sub
Bookmarks