將宏應用于所有打開的Excel作業簿

我正在嘗試創建一個可用于匯總用戶每周提供的資料的宏。我已經撰寫了幾個組合起來做我想做的子程式，但我現在希望能夠在一個檔案夾中的所有作業簿上運行一次 VBA 代碼，并避免我打開每個作業簿然后運行宏。為了給出背景關系，這個想法是總結日常活動并將其放在作業簿中新創建的作業表上，我稱之為“每周總計”，這個想法是我將資料從“每周總計”復制到一個作業簿中稍后點。

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

我創建了一個 Personal.xlsb 以便我可以訪問上面的子例程，并且我有另一個宏可以打開指定檔案夾中的每個作業簿，但是我可以向這個子例程添加什么使它適用于我打開的任意數量的作業簿或者在這個指定的檔案夾中？

編輯：我將包含代碼，因此問題不會不必要地浪費人們的時間。

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

不是我確定最有效或最優雅的，但它確實適用于這一點。打開檔案夾中所有作業簿的代碼是：

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

所有檔案都將具有“YYYYMMDD_Name.xlsx”的命名約定，例如 20211128_JSmith

作業表上的表格如下所示：

等等。

輸出如下所示：

等等。

uj5u.com熱心網友回復：

這部分是因為測驗我們沒有資料來測驗的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

標籤：擅长 vba

上一篇：方法“SeriesCollection.Add”未能通過正確的輸入

下一篇：當只選擇一個單元格時，為什么“ActivecellisSelection”是假的？