根据指定字段，汇总工作簿

yuzhc8818

各位大神好：

           求助了好多大神的帮助，才勉强用起来，但是数据汇总的时候，由于需要汇总的字段太多，各个工作簿里面的字段又不尽相同，故又出了一些问题，请大神帮忙调试一下，见附件如下，不胜感激。

yuzhc8818

附件如下：

abc123281

建议联系原作者
'*********************************
'*******  北极狐工作室出品  ******
'*******  QQ：14885553      ******
'*********************************

yuzhc8818

abc123281 发表于 2019-2-11 15:56
建议联系原作者
'*********************************
'*******  北极狐工作室出品  ******

原作者在休假，没回复

liulang0808

楼主如果想解决问题，
一，联系原作者
二，就是将需求结合附件描述清楚，让大家了解你要做什么及 怎么做。还有现在遇到了什么问题

好牛简历

yuzhc8818 发表于 2019-2-11 13:45
附件如下：

1866年生于法国
罗曼·罗兰---1916年诺贝尔文学奖得主。
人们常觉得准备的阶段是在浪费时间，只有当真正的机会来临，而自己没有能力把握的时候，才能觉悟自己平时没有准备才是浪费时间。
------------------诚赠

当下你要做好3步准备工作
1，第1步：把表格中的字段归纳一下，以及定义
2，第2步：因为下载附件的时候，会有杀病毒软件（直接干掉了）这一块，不知道是否有人提醒过你？
这样把那个汇总的文件，VBA代码单独截个图，以及标出用途
3，第3步：先把【结果】画个示意图，然后大家一块帮你完善，直到完成过程

microyip

好牛简历 发表于 2019-2-11 18:24
1866年生于法国
罗曼·罗兰---1916年诺贝尔文学奖得主。
人们常觉得准备的阶段是在浪费时间，只有当真 ...

好高深的理论，但有道理。同时，对于伸手党来说，没用！

好牛简历

microyip 发表于 2019-2-11 18:29
好高深的理论，但有道理。同时，对于伸手党来说，没用！

浅层是
深层问题产生的环节
No1：第1步，在国内就没有数据库系统（倾向商业方面的教育）单纯是教技术，而不教育应用
No2：第2步，这家公司，是在【手工】---【EXCEL】---【系统数据库】这3个阶段中来回折腾，还没有统一完善
No3：第3步，没有好的垂直行业应用方案出现（本质上会总结的人非常稀缺）
您看看还有补充么
^V^

魂断蓝桥

Sub a()
Dim arr, i&, j%, m&, d, wb As Workbook, mb As Workbook
Dim myf$, brr(1 To 999999, 1 To 7), r%, mr%
myf = Dir(ThisWorkbook.Path & "\数据表\*.xlsx")
Set d = CreateObject("Scripting.Dictionary")
Set mb = ThisWorkbook
mb.Sheets(1).[a1].CurrentRegion.Offset(1, 0).ClearContents
Application.ScreenUpdating = False
Do While myf <> ""
    Set wb = Workbooks.Open(ThisWorkbook.Path & "\数据表\" & myf)
    arr = wb.Sheets(1).[a1].CurrentRegion
    r = wb.Sheets(1).[b99999].End(3).Row
    mr = mb.Sheets(1).[b9999].End(3).Row
    wb.Sheets(1).Range("a3:d" & r).Copy
    mb.Sheets(1).[b1].Offset(mr, 0).PasteSpecial Paste:=xlPasteValues
    mb.Sheets(1).[a1].Offset(mr, 0).Resize(r - 2, 1) = wb.Sheets(1).[a1]
    Application.CutCopyMode = False
    For i = 3 To UBound(arr) - 1
        For j = 5 To UBound(arr, 2)
            m = m + 1
            brr(m, 1) = arr(1, 1)
            brr(m, 2) = arr(i, 1)
            brr(m, 3) = DateSerial(Left(arr(i, 2), 4), Mid(arr(i, 2), 6, 2), Right(arr(i, 2), 2))
            brr(m, 4) = arr(i, 3)
            brr(m, 5) = arr(i, 4)
            brr(m, 6) = arr(2, j)
            brr(m, 7) = arr(i, j)
            d(brr(m, 1) & brr(m, 2) & brr(m, 3) & brr(m, 4) & brr(m, 5) & brr(m, 6)) = brr(m, 7)
        Next
    Next
    wb.Close 0
    myf = Dir()
Loop
Sheet1.Activate
arr = [a1].CurrentRegion
For i = 2 To UBound(arr)
    For j = 6 To UBound(arr, 2)
        arr(i, j) = d(arr(i, 1) & arr(i, 2) & arr(i, 3) & arr(i, 4) & arr(i, 5) & arr(1, j))
    Next
Next
[a1].Resize(UBound(arr), UBound(arr, 2)) = arr
Set d = Nothing
Application.ScreenUpdating = True
End Sub

yuzhc8818

好牛简历 发表于 2019-2-11 18:36
浅层是
深层问题产生的环节
No1：第1步，在国内就没有数据库系统（倾向商业方面的教育）单纯是教技术， ...

说的很全面了，确实如此，公司目前正在做信息规划阶段，但是信息规划前期还是需要通过碎片数据库提供一点商业分析，毕竟管理层需要。感谢您的帮助，非常感谢