自动历遍各子文件夹下的汇总表，并实现...

dtxin

请各位大神帮忙！！

想要的效果：打开社保统计表，按统计按钮，自动历遍各子文件夹下的汇总表，并实现将汇总表的各数据对应赋值给社保统计表的对应项目

蓝桥玄霜

每个汇总表的“征收品目”不完全相同，且上下顺序也不相同？
建议搜索多工作簿提取数据的帖子，有太多。

约定的童话

目测是相当相当的麻烦啊

lkqsmxw

有的时候，不循规蹈矩，就是自寻烦恼。

EXCELLMY

子文件夹，关注一下

opiona

http://club.excelhome.net/thread-1409141-1-1.html

xiangbaoan

Option Explicit
Sub test()
Dim br, i&, j&, k&, s$, t$
Dim d As Object, Cn As Object, Rs As Object, Sq$, sfd, f
Set d = CreateObject("Scripting.Dictionary")
Sheets(1).Activate
br = [a1].CurrentRegion.Resize(2)
For j = 5 To UBound(br, 2)
    If br(1, j) = "" Then br(1, j) = br(1, j - 1)
    d(br(1, j) & br(2, j)) = j
Next
ReDim ar(1 To 2000, 1 To j - 1)
Set Cn = CreateObject("ADODB.Connection")
Cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties='Excel 12.0;HDR=no';Data Source=" & ThisWorkbook.FullName
For Each sfd In CreateObject("Scripting.FileSystemObject").GetFolder(ThisWorkbook.Path).SubFolders
    For Each f In sfd.Files
        If InStr(f, "社会保险费分险种申报汇总表_") Then
            k = k + 1
            Sq = "SELECT * FROM [Excel 12.0;hdr=no;Database=" & f & "].[$a5:g]"
            br = Cn.Execute(Sq).GetRows
            ar(k, 1) = k
            ar(k, 2) = br(1, 0)
            ar(k, 3) = br(5, 0)
            For j = 4 To UBound(br, 2)
                s = br(1, j) & "-" & br(2, j)
                If Not IsNull(br(3, j)) Then ar(k, 4) = ar(k, 4) + Val(br(3, j))
                For i = 4 To UBound(br)
                    t = s & br(i, 2)
                    If d.Exists(t) Then ar(k, d(t)) = br(i, j)
                Next
            Next
        End If
    Next
Next
[a1].CurrentRegion.Offset(2).Clear
If k Then [a3].Resize(k, 31) = ar Else MsgBox "没有数据"
[a1].CurrentRegion.Borders.LineStyle = 1
Cn.Close
Set Cn = Nothing
Set d = Nothing
End Sub

xiangbaoan

………………

dtxin

xiangbaoan 发表于 2019-11-22 15:42
………………

大神你好，1、为什么我加文件夹后，新文件夹不能赋值？2、人数那里不应该是总和，麻烦你修改下

xiangbaoan

dtxin 发表于 2019-11-25 15:51
大神你好，1、为什么我加文件夹后，新文件夹不能赋值？2、人数那里不应该是总和，麻烦你修改下

好吧，等我掐指算一算后再告诉你，OK?
Option Explicit
Sub test() '掐指一算，貌似这样，不上附件，请勿再问
Dim br, i&, j&, k&, s$, t$
Dim d As Object, Cn As Object, Sq$, sfd, f
Set d = CreateObject("Scripting.Dictionary")
Sheets(1).Activate
br = [a1].CurrentRegion.Resize(2)
For j = 5 To UBound(br, 2)
    If br(1, j) = "" Then br(1, j) = br(1, j - 1)
    d(br(1, j) & br(2, j)) = j
Next
ReDim ar(1 To 2000, 1 To j - 1)
Set Cn = CreateObject("ADODB.Connection")
Cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties='Excel 12.0;HDR=no';Data Source=" & ThisWorkbook.FullName
For Each sfd In CreateObject("Scripting.FileSystemObject").GetFolder(ThisWorkbook.Path).SubFolders
    For Each f In sfd.Files
        If f Like "*社会保险费分险种申报汇总表_*.xls*" Then
            k = k + 1
            Sq = "SELECT * FROM [Excel 12.0;hdr=no;Database=" & f & "].[$a5:g]"
            br = Cn.Execute(Sq).GetRows
            ar(k, 1) = k
            ar(k, 2) = sfd.Name
            ar(k, 3) = br(5, 0)
            ar(k, 4) = Val(br(3, 4))
            For j = 4 To UBound(br, 2)
                s = br(1, j) & "-" & br(2, j)
                For i = 4 To UBound(br)
                    t = s & br(i, 2)
                    If d.Exists(t) Then ar(k, d(t)) = br(i, j)
                Next
            Next
        End If
    Next
Next
ActiveSheet.UsedRange.Offset(2).Clear
If k Then [a3].Resize(k, UBound(ar, 2)) = ar Else MsgBox "没有数据"
[a1].CurrentRegion.Borders.LineStyle = 1
Cn.Close
Set Cn = Nothing
Set d = Nothing
End Sub