將宏應用於所有打開的 Excel 工作簿

這部分是因為測試我們沒有數據來測試的SumRowsValues，SumColumnsValues並且CopyFromWorksheets但它應該工作，因為我沒有太多從中除了更改範圍基準掉改變ActiveWorkbook和Activesheet。

我試圖對原始代碼進行盡可能少的更改，因為此答案僅關注如何連接OpenAllFilesDirectory到DoEverything. 有很多事情可以簡化和改進。

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