求字典法解决跨工作簿提取数据问题

同心/ty

同一路径多个工作簿，在'统计表'中写入代码，通过身份证号提取‘基础表1’中O列至T列数据并求和，将结果写入统计表O列.    求大师指教。

同心/ty

别沉哟，求大师出手

bxm78

用字典即可

ykcbf1100

参与一下。

吴中泉

同心/ty 发表于 2023-5-17 08:30
别沉哟，求大师出手

这个用字典还是很方便的，等有时间弄一下

三分醉，七分醒

请测试一下                 

shiruiqiang

字典处理一下，不包售后

sdytsxd991122

参与一下

吴中泉

同心/ty 发表于 2023-5-17 08:30
别沉哟，求大师出手

还是来迟了仅供参考

吴中泉

吴中泉 发表于 2023-5-17 10:01
还是来迟了仅供参考

附上代码

Sub 合计汇总()
Application.ScreenUpdating = False
Set d = CreateObject("Scripting.Dictionary")
lj = ThisWorkbook.Path & "\"
With Sheets("Sheet1")
    arr = .Range("a6").CurrentRegion.Value
    For i = 2 To UBound(arr)
        d(arr(i, 5)) = i
    Next
    f = Dir(lj & "*.xls*")
    Do While f <> ""
      If f <> ThisWorkbook.Name Then
      Set wb = Workbooks.Open(lj & f, 0)
      Set sht = wb.Worksheets(1)
      brr = sht.UsedRange.Value
        For i = 2 To UBound(brr)
            If d.exists(brr(i, 7)) Then
                he = 0
                For j = 15 To 20
                    he = brr(i, j) + he
                Next
                arr(d(brr(i, 7)), 15) = he
            End If
        Next
        wb.Close False
      End If
    f = Dir
    Loop
    .Range("a6").CurrentRegion = arr
End With
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub