Apply a macro to all opened Excel Workbooks - excel

Question

I am trying to create a macro that can be used to summarise data provided by users on a weekly basis. I have written several Subroutines that combined do what I want, but I'm now looking to be able to run the VBA code once on all workbooks in a folder and save me from opening each one and then running the macro.
To give context the idea is to sum daily activity and place this on a newly created worksheet in the workbook which I call "Weekly Totals", the idea being that I'll copy the data from "Weekly Totals" to a single workbook at a later point.
Sub DoEverything()
Dim ws As Worksheet
For Each ws In Worksheets
ws.Activate
SumRowsValues
SumColumnsValues
Next ws
AddTotalSheet
CopyFromWorksheets
ListSheetNames
GetFileName
RemoveTextBeforeUnderscore
StringToDate
End Sub
I have created a Personal.xlsb so that I can access the Subroutine above and I have another macro that opens every workbook within a designated folder, but what can I add to this Subroutine that would make it apply to any number of workbooks that I open or that are in this designated folder?
Edit:
I shall include the code so the question is not wasting people's time unnecessarily.
Sub SumRowsValues()
Dim i As Long
For i = 4 To 44
If Application.WorksheetFunction.Sum(Range(Cells(i, 3), Cells(i, 10))) <> 0 Then
Cells(i, 11) = 15
End If
Next i
End Sub
Sub SumColumnsValues()
Dim i As Long
For i = 3 To 11
Cells(45, i) = Application.WorksheetFunction.Sum(Range(Cells(4, i), Cells(44, i)))
Next i
End Sub
Sub AddTotalSheet()
Sheets.Add(Before:=Sheets("Mon")).Name = "Weekly Totals"
End Sub
Sub CopyFromWorksheets()
Worksheets("Weekly Totals").Range("A1").Value = "Date"
Worksheets("Weekly Totals").Range("B1").Value = "Person"
Worksheets("Weekly Totals").Range("C1").Value = "Day"
Worksheets("Mon").Range("C3:K3").Copy Worksheets("Weekly Totals").Range("D1")
Worksheets("Mon").Range("C45:K45").Copy Worksheets("Weekly Totals").Range("D2")
Worksheets("Tue").Range("C45:K45").Copy Worksheets("Weekly Totals").Range("D3")
Worksheets("Wed").Range("C45:K45").Copy Worksheets("Weekly Totals").Range("D4")
Worksheets("Thu").Range("C45:K45").Copy Worksheets("Weekly Totals").Range("D5")
Worksheets("Fri").Range("C45:K45").Copy Worksheets("Weekly Totals").Range("D6")
End Sub
Sub ListSheetNames()
Dim ws As Worksheet
Sheets("Weekly Totals").Activate
ActiveSheet.Cells(2, 3).Select
For Each ws In Worksheets
If ws.Name = "Weekly Totals" Then
Else
ActiveCell = ws.Name
ActiveCell.Offset(1, 0).Select
End If
Next
End Sub
Sub GetFileName()
Dim strFileFullName, DateText, NameText, strDuplicateFileName As String
strFileFullName = ActiveWorkbook.Name
strDuplicateFileName = strFileFullName
DateText = Split(strFileFullName, "_")
NameText = Split(strDuplicateFileName, ".")
Worksheets("Weekly Totals").Range("A2").Value = DateText
Worksheets("Weekly Totals").Range("B2").Value = NameText
End Sub
Sub RemoveTextBeforeUnderscore()
Dim i As Long '
Dim rng As Range
Dim cell As Range
Set rng = Worksheets("Weekly Totals").Range("B2")
For i = 1 To 5 '
For Each cell In rng
cell(i, 1).Value = Right(cell.Value, Len(cell.Value) + 1 - InStr(cell.Value, "_") - 1)
Next cell
Next i
End Sub
Sub StringToDate()
Dim InitialValue As Long
Dim DateAsString As String
Dim FinalDate As Date
InitialValue = Worksheets("Weekly Totals").Range("A2").Value
DateAsString = CStr(InitialValue)
FinalDate = DateSerial(CInt(Left(DateAsString, 4)), CInt(Mid(DateAsString, 5, 2)), CInt(Right(DateAsString, 2)))
Range("A2").Value = FinalDate
Range("A3").Value = FinalDate + 1
Range("A4").Value = FinalDate + 2
Range("A5").Value = FinalDate + 3
Range("A6").Value = FinalDate + 4
Columns("A").AutoFit
End Sub
Not I am sure the most efficient or elegant, but it does work to this point. The code for opening all workbooks in a folder is:
Sub OpenAllFilesDirectory()
Dim Folder As String, FileName As String
Folder = "pathway..."
FileName = Dir(Folder & "\*.xlsx")
Do
Workbooks.Open Folder & "\" & FileName
FileName = Dir
Loop Until FileName = ""
End Sub
All the files will having the naming convention of "YYYYMMDD_Name.xlsx", e.g. 20211128_JSmith
The table on worksheet looks like this:
etc.
The output looks like this:
etc.

Answer 1

This is partially tested since we have no data to test for the SumRowsValues, SumColumnsValues and CopyFromWorksheets but it should work as I did not change much from it other than changing the range reference away from ActiveWorkbook and Activesheet.
I have tried to change as little as possible from the original code as this answer is only focused on how to connect OpenAllFilesDirectory to DoEverything. There are many things that can be streamlined and improve on.
Option Explicit
Const TOTAL_WSNAME As String = "Weekly Totals"
Sub OpenAllFilesDirectory()
Dim Folder As String, FileName As String
Folder = "pathway..."
FileName = Dir(Folder & "\*.xlsx")
Do
Dim currentWB As Workbook
Set currentWB = Workbooks.Open(Folder & "\" & FileName)
DoEverything currentWB
FileName = Dir
Loop Until FileName = ""
End Sub
Sub DoEverything(argWB As Workbook)
Dim ws As Worksheet
For Each ws In argWB.Worksheets
SumRowsValues ws
SumColumnsValues ws
Next ws
Dim totalWS As Worksheet
Set totalWS = AddTotalSheet(argWB)
CopyFromWorksheets argWB
ListSheetNames argWB
GetFileName totalWS
RemoveTextBeforeUnderscore totalWS
StringToDate totalWS
End Sub
Sub SumRowsValues(argWS As Worksheet)
Dim i As Long
For i = 4 To 44
If Application.WorksheetFunction.Sum(argWS.Range(argWS.Cells(i, 3), argWS.Cells(i, 10))) <> 0 Then
argWS.Cells(i, 11) = 15
End If
Next i
End Sub
Sub SumColumnsValues(argWS As Worksheet)
Dim i As Long
For i = 3 To 11
argWS.Cells(45, i) = Application.WorksheetFunction.Sum(argWS.Range(argWS.Cells(4, i), argWS.Cells(44, i)))
Next i
End Sub
Function AddTotalSheet(argWB As Workbook) As Worksheet
Dim totalWS As Worksheet
Set totalWS = argWB.Sheets.Add(Before:=argWB.Sheets("Mon"))
totalWS.Name = TOTAL_WSNAME
Set AddTotalSheet = totalWS
End Function
Sub CopyFromWorksheets(argWB As Workbook)
Dim totalWS As Worksheet
Set totalWS = argWB.Worksheets(TOTAL_WSNAME)
totalWS.Range("A1").Value = "Date"
totalWS.Range("B1").Value = "Person"
totalWS.Range("C1").Value = "Day"
argWB.Worksheets("Mon").Range("C3:K3").Copy totalWS.Range("D1")
argWB.Worksheets("Mon").Range("C45:K45").Copy totalWS.Range("D2")
argWB.Worksheets("Tue").Range("C45:K45").Copy totalWS.Range("D3")
argWB.Worksheets("Wed").Range("C45:K45").Copy totalWS.Range("D4")
argWB.Worksheets("Thu").Range("C45:K45").Copy totalWS.Range("D5")
argWB.Worksheets("Fri").Range("C45:K45").Copy totalWS.Range("D6")
End Sub
Sub ListSheetNames(argWB As Workbook)
Dim insertCell As Range
Set insertCell = argWB.Worksheets(TOTAL_WSNAME).Range("C2")
Dim ws As Worksheet
For Each ws In argWB.Worksheets
If ws.Name <> TOTAL_WSNAME Then
insertCell.Value = ws.Name
Set insertCell = insertCell.Offset(1)
End If
Next
End Sub
Sub GetFileName(argWS As Worksheet)
Dim strFileFullName As String
Dim DateText As String
Dim NameText As String
strFileFullName = argWS.Parent.Name
DateText = Split(strFileFullName, "_")(0)
NameText = Split(strFileFullName, ".")(0)
argWS.Range("A2").Value = DateText
argWS.Range("B2").Value = NameText
End Sub
Sub RemoveTextBeforeUnderscore(argWS As Worksheet)
Dim i As Long
Dim rng As Range
Dim cell As Range
Set rng = argWS.Range("B2")
For i = 1 To 5 '
For Each cell In rng
cell(i, 1).Value = Right(cell.Value, Len(cell.Value) + 1 - InStr(cell.Value, "_") - 1)
Next cell
Next i
End Sub
Sub StringToDate(argWS As Worksheet)
Dim InitialValue As Long
Dim DateAsString As String
Dim FinalDate As Date
InitialValue = argWS.Range("A2").Value
DateAsString = CStr(InitialValue)
FinalDate = DateSerial(CInt(Left(DateAsString, 4)), CInt(Mid(DateAsString, 5, 2)), CInt(Right(DateAsString, 2)))
argWS.Range("A2").Value = FinalDate
argWS.Range("A3").Value = FinalDate + 1
argWS.Range("A4").Value = FinalDate + 2
argWS.Range("A5").Value = FinalDate + 3
argWS.Range("A6").Value = FinalDate + 4
argWS.Columns("A").AutoFit
End Sub