Apply a macro to all opened Excel Workbooks

splitznook

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:

enter image description here

etc.

The output looks like this:

enter image description here

etc.

Raymond Wu

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

Este artículo se recopila de Internet, indique la fuente cuando se vuelva a imprimir.

En caso de infracción, por favor [email protected] Eliminar

Editado en
0

Déjame decir algunas palabras

0Comentarios
Iniciar sesiónRevisión de participación posterior

Artículos relacionados

Read all worksheets (as dataframes) from multiple Excel workbooks of different structure

Reply All in Outlook from Excel Macro

Unprotect the Excel workbooks in a specified path and refresh the workbook conection and then protect the workbooks

Unprotect the Excel workbooks in a specified path and refresh the workbook conection and then protect the workbooks

c # Excel Interop _Workbooks.Open

Using Excel VBA to move columns for different workbooks

c # Excel Interop _Workbooks.Open

Excel Solver usando Macro

Excel VBA - =lookup in macro

Macro Excel à regrouper

VBA Macro - автоматический перевод моего текста в Excel

Excel копирует содержимое с одного листа на другой без VBA / Macro

How to convert first worksheet of several excel workbooks into pdf in PowerShell?

Excel VBA Workbooks.open avec des paramètres facultatifs

Workbooks.OpenText no analiza los archivos csv correctamente Excel 2016

Excel VBA: Workbooks.Open devuelve el objeto incorrecto

Combining excel workbooks with same header columns but various rows in a master wb

Excel VBA Workbooks.open con parámetros opcionales

Copy specific worksheets in all active or open workbooks in vba

excel application is not shown in task manager when It is opened

Istio - what for all these ports are opened on LoadBalancer?

seleccionar rango en Excel macro

Macro de Excel (datos separados)

Multiplicar elementos en Excel Macro

seleccionar rango en Excel macro

seleccionar rango en Excel macro

Recorrer la macro de Excel

Cuente en Excel usando macro

Apply CSS to all but last element?

TOP Lista

CalienteEtiquetas

Archivo