Apply a macro to all opened Excel Workbooks-CodePudding

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.

CodePudding user response：

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