☰

폴더의 모든 통합 문서 범위에 있는 모든 값을 다른 통합 문서로 합산하는 VBA 루틴

tag-icon • tag-icon microsoft-excel vba
폴더의 모든 통합 문서 범위에 있는 모든 값을 다른 통합 문서로 합산하는 VBA 루틴

내가 가지고 있는 것: 어딘가에서 찾은 VBA 루틴으로 내 문제에 적응하려고 노력했습니다. 이 루틴은 폴더의 모든 Excel 통합 문서를 찾고 H8:H27 범위의 모든 파일을 새 통합 문서에 병합한다는 것을 이해합니다.

필요한 것: 폴더에서 모든 Excel 통합 문서(totals.xlsx 제외)를 찾고 Sheet(2)H8:H27 범위의 값을 통합 문서 totals.xlsx에 합산하는 루틴입니다! 시트(2)H8:H27

totals.xlsx라는 통합 문서 하나를 포함하여 67개의 Excel 통합 문서가 포함된 폴더가 있습니다.

totals.xls를 제외한 다른 통합 문서에는 큰 이름이 있습니다. 모든 책의 시트 번호 2에도 거대한 이름이 있습니다.

모든 책은 동일한 구조를 가지고 있습니다.

범위 시트(2)H8:H27의 모든 통합 문서(totals.xlsx 제외) 값을 통합 문서 total.xls의 동일한 범위로 합산해야 합니다! 시트 (2)H8:H27;

파일 제한이 50개이므로 통합 도구를 사용할 수 없습니다.

큰 이름을 가진 67개의 통합 문서를 참조하는 공식을 작성하는 것은 거의 불가능합니다. 시트 (2)도 큰 이름을 가지고 있습니다.

그래서 폴더에 있는 모든 통합 문서(totals.xlsx 제외)의 H8:H27 범위에 있는 SUM 값에 대한 VBA 루틴을 totals.xlsx 통합 문서 시트(2)의 동일한 범위에 대해 생각했습니다.

다음 VBA 루틴을 찾아서 적용했습니다. 거의 다 온 것 같지만 지금까지는 값을 별도의 통합 문서로 병합할 수 있었습니다. 모든 통합 문서(totals.xlsx 제외)를 합산하는 방법을 모릅니다! 시트 (2)H8:H27을 totals.xlsx로! 시트(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_WB()

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

서브 끝

관련 정보