Selected Answer
Wehttam
In the first attached file, you'll find two sheets. The second is "Summary template" - don't change this since it will be used to collect your data from files you list in column A of the first sheet ("Target files") plus the start cell data in column C.
The latter sheet shows the "output" results using files on my PC (where B317.xlsx is just a copy of your B308.xlsx file and there's no B320 file).
Firstly replace the filenames in A with real files and paths (you could have 20 or more).
Then to get an idea of the basic process, use key combination Alt+F11 to display the VB Explorer window. If you don't see a pane tilted "Immediate", press Ctrl+G to display it. Then double click on Module2 to display this macro (with explanatory comments:in red, starting '):
Sub ListFileSheets()
Dim LstRw As Long, TargLstRw As Long, DestLstRw As Long
Dim n As Long, FlNm As String, Wb As Workbook, Ws As Worksheet
'don't update the screen (so file opening is hidden too)
Application.ScreenUpdating = False
' determine last used row in column A
LstRw = Sheet1.Cells(Rows.Count, "A").End(xlUp).Row
'loop down column A from row 2
For n = 2 To LstRw
' check if file exists
FlNm = Dir(Sheet1.Cells(n, 1).Value)
If FlNm <> vbNullString Then
'<< do something >>
Debug.Print "Found " & FlNm
Set Wb = Workbooks.Open(Sheet1.Cells(n, 1).Value)
' loop through all sheets
For Each Ws In Wb.Sheets
' << do something only to claim sheets>>
If Ws.Name <> "Summary" Then Debug.Print "Found sheet " & Ws.Name & ": Claim No. " & Ws.Cells(6, 6).Value
Next Ws
' close file
Wb.Close SaveChanges:=False
Else
' say if the file wasn't found
Debug.Print "Couldn't find " & Sheet1.Cells(n, 1).Value
End If
Next n
Application.ScreenUpdating = True
End Sub
If you click in that and press the Play icon in the menu bar (next to the Pause icon), the macro will (invisibly) open all your files and a list of results will appear in that Immediate window (you can scroll up/down).
Now return to the "Target files" sheet, find the blue button labelled "Create Summary files" near column E, click it and respond "Yes" to the Message Box and after a short while another message will tell you it's done i.e. it has run this much fuller macro from Module1 (with comments in red again):
Sub CollateClaims()
Dim LstRw As Long, FlLstRw As Long, DestLstRw As Long
Dim n As Long, m As Long, Strt As String
Dim FlNm As String, Wb As Workbook, Ws As Worksheet
Dim Resp As VbMsgBoxResult
' determine last used row in column A
LstRw = Sheet1.Cells(Rows.Count, "A").End(xlUp).Row
Resp = MsgBox("Okay to clear output data, search files and overwrite any Summary files with today's date?", vbYesNo, "This may take a few seconds....")
If Resp <> vbYes Then Exit Sub
' clear output columns
ThisWorkbook.Worksheets("Target files").Range("C2:D" & LstRw).ClearContents
'don't update the screen (so file opening is hidden too)
Application.ScreenUpdating = False
'loop down column A from row 2
For n = 2 To LstRw
' check if file exists
FlNm = Dir(Sheet1.Cells(n, 1).Value)
If FlNm <> vbNullString Then
' open found workbook
Set Wb = Workbooks.Open(Sheet1.Cells(n, 1).Value)
' make a copy of the summary template
ThisWorkbook.Worksheets("Summary Template").Copy
' loop through all sheets
For Each Ws In Wb.Sheets
' ignore any Summary sheets
If Ws.Name <> "Summary" Then
' fix start cell for this file (or set B315 if blank)
Strt = Sheet1.Cells(n, 2).Value
If Strt = "" Then Strt = "B315"
' and extract claim data
With Ws.Range(Strt)
' determine last used row in starter column
FlLstRw = Ws.Cells(Rows.Count, .Column).End(xlUp).Row
For m = .Row To FlLstRw
If Ws.Cells(m, .Column) <> "" And _
Not (Ws.Cells(m, .Column + 2) = "" Or Ws.Cells(m, .Column + 2) = "-") Then
' copy data
Select Case Ws.Cells(m, .Column - 1)
Case "Labour"
' get last used row in appropriate output area of Summary
DestLstRw = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row
' copy range of data and paste values and formats below there
Ws.Range(Ws.Cells(m, .Column + 2), Ws.Cells(m, .Column + 19)).Copy
ActiveSheet.Cells(DestLstRw + 1, "C").PasteSpecial xlPasteValues
ActiveSheet.Cells(DestLstRw + 1, "C").PasteSpecial xlPasteFormats
' and write project and claim data
ActiveSheet.Cells(DestLstRw + 1, "A") = Left(Wb.Name, 4)
ActiveSheet.Cells(DestLstRw + 1, "B") = "Claim " & Ws.Cells(6, 6)
' write borders
ActiveSheet.Cells(DestLstRw + 1, "A").Borders.LineStyle = xlContinuous
ActiveSheet.Cells(DestLstRw + 1, "B").Borders.LineStyle = xlContinuous
Case "Material"
DestLstRw = ActiveSheet.Cells(Rows.Count, "V").End(xlUp).Row
Ws.Range(Ws.Cells(m, .Column + 2), Ws.Cells(m, .Column + 14)).Copy
ActiveSheet.Cells(DestLstRw + 1, "X").PasteSpecial xlPasteValues
ActiveSheet.Cells(DestLstRw + 1, "X").PasteSpecial xlPasteFormats
ActiveSheet.Cells(DestLstRw + 1, "V") = Left(Wb.Name, 4)
ActiveSheet.Cells(DestLstRw + 1, "W") = "Claim " & Ws.Cells(6, 6)
ActiveSheet.Cells(DestLstRw + 1, "V").Borders.LineStyle = xlContinuous
ActiveSheet.Cells(DestLstRw + 1, "W").Borders.LineStyle = xlContinuous
Case "Equipment"
DestLstRw = ActiveSheet.Cells(Rows.Count, "AL").End(xlUp).Row
Ws.Range(Ws.Cells(m, .Column + 2), Ws.Cells(m, .Column + 14)).Copy
ActiveSheet.Cells(DestLstRw + 1, "AN").PasteSpecial xlPasteValues
ActiveSheet.Cells(DestLstRw + 1, "AN").PasteSpecial xlPasteFormats
ActiveSheet.Cells(DestLstRw + 1, "AL") = Left(Wb.Name, 4)
ActiveSheet.Cells(DestLstRw + 1, "AM") = "Claim " & Ws.Cells(6, 6)
ActiveSheet.Cells(DestLstRw + 1, "AL").Borders.LineStyle = xlContinuous
ActiveSheet.Cells(DestLstRw + 1, "AM").Borders.LineStyle = xlContinuous
Case Else
DestLstRw = ActiveSheet.Cells(Rows.Count, "BB").End(xlUp).Row
Ws.Range(Ws.Cells(m, .Column + 2), Ws.Cells(m, .Column + 19)).Copy_
ActiveSheet.Cells(DestLstRw + 1, "BD").PasteSpecial xlPasteValues
ActiveSheet.Cells(DestLstRw + 1, "BD").PasteSpecial xlPasteFormats
ActiveSheet.Cells(DestLstRw + 1, "BB") = Left(Wb.Name, 4)
ActiveSheet.Cells(DestLstRw + 1, "BC") = "Claim " & Ws.Cells(6, 6)
ActiveSheet.Cells(DestLstRw + 1, "BB").Borders.LineStyle = xlContinuous
ActiveSheet.Cells(DestLstRw + 1, "BC").Borders.LineStyle = xlContinuous
End Select
End If
Next m
End With
'Debug.Print Ws.Name
End If
Next Ws
' save summary in same folder as source, without asking
Application.DisplayAlerts = False
FlNm = Wb.Path & "\" & Left(Wb.Name, 4) & " Summary " & Format(Date, "ddmmyyyy") & ".xlsx"
ActiveWorkbook.SaveAs (FlNm)
' close filea
ActiveWorkbook.Close
Application.DisplayAlerts = True
Wb.Close SaveChanges:=False
' write output values
Sheet1.Cells(n, 3).Value = "Saved Summary as " & FlNm
Sheet1.Cells(n, 4).Value = Now
Else
' say if the file wasn't found
Sheet1.Cells(n, 3).Value = "Couldn't find " & Sheet1.Cells(n, 1).Value
Sheet1.Cells(n, 4).Value = "-"
End If
Next n
Application.ScreenUpdating = True
MsgBox "Done! (See action info in columns C and D)"
End Sub
You'll find that it creates Summary files per project (named like B308 Summary 01042024.xlsx where the numeric bit is today's date in ddmmyyyy format) inthe same folder as that in column A.
Note that it relies on there being a number in column B of your files (like B308.xlsx), a category in column A and data in column D on. It will ignore any rows which match that but have "-" or nothing (no name or description) in D.
In the template sheet, there's also an "Uncategorised" section over to the right (in case column A of your source file's data row doesn't match Labour, Material or Equipment).
This then is the file to use weekly (or whatever) to create your Summary files.
Hope this fixes your problem. If so, please be sure to mark this Answer as Selected.