求助:快速统计文件夹所有excel文档所有工作表数据

he_zai

数据源工作簿里面所有的模板相同：
里面有差旅费、办公费、维修费、培训费等科目；


需求实现：利用vba代码执行所有数据源文件夹里的工作簿、工作表、把所有科目行有金额复制到以下工作簿中，并带源工作簿名和工作表


现代码：但一次只能一个科目，只能读取一个工作簿的内容。

Sub byWanao()
    Dim i%, j%, endRow%, un$, arr, sht As Worksheet, WB As Workbook
    Dim Path$, fileName$, findData$, brr()
    'i 行
    'j列
   
    endRow = 2
    findData = "差旅费"
    Path = ThisWorkbook.Path & "\数据\"
    fileName = Dir(Path & "*.xlsx", vbDirectory)
    Do
        If Len(fileName) = 0 Then Exit Do
        Set WB = GetObject(Path & fileName)
        For Each sht In WB.Sheets
           
            arr = sht.UsedRange
            'Debug.Print arr
            For i = 1 To UBound(arr)
                If arr(i, 2) <> "" Then
                    If findData = arr(i, 2) Then
                        endRow = endRow + 1
                        'ReDim Preserve brr(1 To 5, 1 To endRow)
                        For j = 1 To 6
                           
                         'brr(i, endRow) = arr(i, j)
                            Cells(i, j) = arr(i, j)
                            'cells(i,j)中i指的是行数，j指的是列数，
                        Next
                         Cells(i, j) = fileName
                         Cells(i, j + 1) = sht.Name
                        'brr(7, endRow) = fileName
                        'brr(8, endRow) = sht.Name
                    End If
                End If
            Next
        Next
        Set WB = Nothing
        fileName = Dir()
    Loop
    'Stop
    'Range("a5").Resize(UBound(brr, 2), UBound(brr)) = Application.Transpose(brr)
End Sub

LIUZHU

汇总工作表中的序号，是要保留数据源中的原始序号，还是重新编号？

LIUZHU

LIUZHU

WPS测试，JS宏

cjc209

Sub byWanao()
    Dim arr, brr(), sht As Worksheet, WB As Workbook
    ReDim brr(1 To 10000, 1 To 8)
    Path = ThisWorkbook.Path & "\数据\"
    fileName = Dir(Path & "*.xlsx", vbDirectory)
    Do
        If Len(fileName) = 0 Then Exit Do
        Set WB = Workbooks.Open(Path & fileName)
        For Each sht In WB.Sheets
            arr = sht.UsedRange
            For i = 1 To UBound(arr)
                If arr(i, 3) <> "" And arr(i, 3) <> "姓名" And arr(i, 3) <> "账户名称" Then
                    k = k + 1
                    For j = 1 To 6
                        brr(k, j) = arr(i, j)
                    Next
                    brr(k, 7) = fileName
                    brr(k, 8) = sht.Name
                End If
            Next
        Next
        WB.Close False
        fileName = Dir()
    Loop
    Sheet1.Range("a2").Resize(k, UBound(brr, 2)) = brr
End Sub

ykcbf1100

附件请参考。。。

gwjkkkkk

Option Explicit
Sub test()
    Dim ar, br, i&, j&, r&, strFileName$, strPath$, wks As Worksheet

    Application.ScreenUpdating = False
    With [A1].CurrentRegion
        .Offset(1).Clear
        ar = .Resize(10 ^ 3)
        r = 1
    End With
   
    strPath = ThisWorkbook.Path & "\数据\"
    strFileName = Dir(strPath & "*.xls*")
    Do Until strFileName = ""
        If strFileName <> ThisWorkbook.Name Then
            With GetObject(strPath & strFileName)
                For Each wks In .Sheets
                    With wks
                        br = Range(.[A1], .UsedRange)
                        For i = 1 To UBound(br)
                            If Val(br(i, 6)) > 0 And br(i, 2) <> "" Then
                                 r = r + 1
                                 For j = 2 To 6
                                     ar(r, j) = br(i, j)
                                 Next j
                                 ar(r, 1) = r - 1: ar(r, 7) = .Parent.Name: ar(r, 8) = .Name
                            End If
                        Next i
                    End With
                Next
                .Close False
            End With
        End If
        strFileName = Dir
    Loop
   
    With [A1].Resize(r, UBound(ar, 2))
         .Columns(4).NumberFormatLocal = "@"
         .Value = ar
        .HorizontalAlignment = xlCenter
        .Borders.LineStyle = xlContinuous
        .EntireColumn.AutoFit
        .EntireRow.AutoFit
    End With
    Application.ScreenUpdating = True
    Beep
End Sub

gwjkkkkk

参与一下。。。

he_zai

花朵每日有上限，问题已经解决，感谢楼上的大神解答，每位的都可以了。