☰

VBA 例程将文件夹中所有工作簿范围内的所有值相加并保存到另一个工作簿中

tag-icon • tag-icon microsoft-excel vba
VBA 例程将文件夹中所有工作簿范围内的所有值相加并保存到另一个工作簿中

我所拥有的：我在某处找到并尝试适应我的问题的 VBA 例程。我了解此例程会查找文件夹中的所有 Excel 工作簿，并将所有文件范围 H8:H27 合并到新工作簿中。

我需要的：一个例程，用于查找文件夹中的所有 Excel 工作簿（不包括 totals.xlsx），并将范围 Sheet(2)H8:H27 中的值加总到工作簿 totals.xlsx！sheet(2)H8:H27

我有一个包含 67 个 Excel 工作簿的文件夹，其中一个名为 totals.xlsx 的工作簿；

除 totals.xls 外，其他工作簿的名称都很大。所有工作簿中的工作表编号 2 的名称也很大。

所有的书都有相同的结构；

我需要将范围 sheet(2)H8:H27 中的所有工作簿（不包括 totals.xlsx）值加总到工作簿 total.xls 中的相同范围内！sheet (2)H8:H27;

我无法使用合并工具，因为文件数量限制为 50 个；

编写一个引用 67 个具有巨大名称的工作簿的公式几乎是不可能的，其中工作表 (2) 也具有巨大名称；

因此，我确实考虑过使用 VBA 例程将文件夹中所有工作簿（不包括 totals.xlsx）的 H8:H27 范围内的值汇总到 totals.xlsx 工作簿的工作表 (2) 中的相同范围内

我找到并改编了以下 VBA 例程。我想我快完成了，但到目前为止，我已经能够将值合并到一个单独的工作簿中。不知道如何将所有工作簿（不包括 totals.xlsx）相加！sheet (2)H8:H27 到 totals.xlsx！sheet(2)H8:H27

Sub MergeAllWorkbooks()
    Dim MyPath As String, FilesInPath As String
    Dim MyFiles() As String
    Dim SourceRcount As Long, FNum As Long
    Dim mybook As Workbook, BaseWks As Worksheet
    Dim sourceRange As Range, destrange As Range
    Dim rnum As Long, CalcMode As Long
    MyPath = "C:\Users\test"
    If Right(MyPath, 1) <> "\" Then
        MyPath = MyPath & "\"
    End If
    FilesInPath = Dir(MyPath & "*.xl*")
    If FilesInPath = "" Then
        MsgBox "No files found"
        Exit Sub
    End If
    FNum = 0
    Do While FilesInPath <> ""
        FNum = FNum + 1
        ReDim Preserve MyFiles(1 To FNum)
        MyFiles(FNum) = FilesInPath
        FilesInPath = Dir()
    Loop
    With Application
        CalcMode = .Calculation
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
        .EnableEvents = False
    End With
    Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
    rnum = 1

    If FNum > 0 Then
        For FNum = LBound(MyFiles) To UBound(MyFiles)
            Set mybook = Nothing
            On Error Resume Next
            Set mybook = Workbooks.Open(MyPath & MyFiles(FNum))
            On Error GoTo 0
            If Not mybook Is Nothing Then
                On Error Resume Next
                With mybook.Worksheets(1)
                    Set sourceRange = .Range("A1:C1")
                End With

                If Err.Number > 0 Then
                    Err.Clear
                    Set sourceRange = Nothing
                Else
                    If sourceRange.Columns.Count >= BaseWks.Columns.Count Then
                        Set sourceRange = Nothing
                    End If
                End If
                On Error GoTo 0
                If Not sourceRange Is Nothing Then
                    SourceRcount = sourceRange.Rows.Count
                    If rnum + SourceRcount >= BaseWks.Rows.Count Then
                        MsgBox "There are not enough rows in the target worksheet."
                        BaseWks.Columns.AutoFit
                        mybook.Close savechanges:=False
                        GoTo ExitTheSub
                    Else

                        With sourceRange
                            BaseWks.Cells(rnum, "A"). _
                                    Resize(.Rows.Count).Value = MyFiles(FNum)
                        End With
                        Set destrange = BaseWks.Range("B" & rnum)
                        With sourceRange
                            Set destrange = destrange. _
                                            Resize(.Rows.Count, .Columns.Count)
                        End With
                        destrange.Value = sourceRange.Value
                        rnum = rnum + SourceRcount
                    End If
                End If
                mybook.Close savechanges:=False
            End If
        Next FNum
        BaseWks.Columns.AutoFit
    End If
ExitTheSub:
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = CalcMode
    End With
End Sub

答案1

解决了！

子 SUM_WBs()

Dim FileNameXls As Variant, i As Integer, wb As Workbook

Range("H8:H27").ClearContents

FileNameXls = Application.GetOpenFilename(filefilter:="Excel Files, *.xl*", MultiSelect:=True)
If Not IsArray(FileNameXls) Then Exit Sub

Application.ScreenUpdating = False

For i = LBound(FileNameXls) To UBound(FileNameXls)

    Set wb = Workbooks.Open(FileNameXls(i))
    wb.Sheets(2).Range("H8:H27").Copy
    ThisWorkbook.Sheets(2).Range("H8:H27").PasteSpecial Paste:=xlPasteValues, Operation:=xlAdd, SkipBlanks:=True, Transpose:=False
    Application.CutCopyMode = False
    wb.Close SaveChanges:=False

Next i

Application.ScreenUpdating = True

子目录结束

相关内容