[已解决][求助]多工作簿汇总

河山

    我想把语文科,数学科,英语科这三个工作簿的数据汇总到"汇总表"里,我试用公式链接,最终还是不理想,本人对vba又不懂,希望高手们用vba帮我解决一下这个难题.只要点击按扭"汇总"数据就自动生成如附件一样的数据表,注意,所有的工作簿都以进行了保护,但每个工作簿的数据单元格都是在"永许拥护编辑区域"内,姓名均相同,要求在保护状态下进行.老弟在这里先谢谢了.

7MoatCam.rar (7.34 KB, 下载次数: 70)

2008-9-27 22:33 上传

点击文件名下载附件
[求助]多工作簿汇总

最佳答案

月排行榜 / 总排行榜

wxyqxxz2007

2008-10-5 20:06

Sub yy()
 Application.ScreenUpdating = False
   Set aw = ThisWorkbook
   ar = aw.Sheets("汇总表").Range("d8:g28")
      Set d = CreateObject("scripting.dictionary")
      For i = 1 To UBound(ar)
        If Not d.exists(ar(i, 1)) Then d.Add ar(i, 1), i
      Next
        p = aw.Path & "\"
        f = Dir(p & "*.xls")
        Do While f <> ""
          If f <> ThisWorkbook.Name Then
            Set wk = GetObject(p & f)
            ar2 = wk.Sheets(1).Range("e9:f29")
              Set c = aw.Sheets("汇总表").Range("d7:g7").Find(Left(wk.Name, Len(wk.Name) - 4))
                For i = 1 To UBound(ar2)
                  If d.exists(ar2(i, 1)) Then
                    ar(d(ar2(i, 1)), c.Column - 3) = ar2(i, 2)
                  End If
                Next
            wk.Close False
           End If
        f = Dir
        Loop
   aw.Sheets("汇总表").Range("d8:g28") = ar
 Application.ScreenUpdating = True
End Sub

 

Xizgxd0E.rar (9.1 KB, 下载次数: 92)

2008-10-5 20:07 上传

点击文件名下载附件

[此贴子已经被作者于2008-10-5 20:07:02编辑过]

跳转到最佳答案楼层

laosanjie

用VBA做了一个，已经可以实现楼主的要求：

[hide]

KM7LQaUy.rar (22.27 KB, 下载次数: 82)

2008-9-29 19:34 上传

点击文件名下载附件
[求助]多工作簿汇总

[/hide

]

河山

感谢laosanjie兄弟的帮忙,我下来试了还是不行

wxyqxxz2007

Sub yy()
 Application.ScreenUpdating = False
   Set aw = ThisWorkbook
   ar = aw.Sheets("汇总表").Range("d8:g28")
      Set d = CreateObject("scripting.dictionary")
      For i = 1 To UBound(ar)
        If Not d.exists(ar(i, 1)) Then d.Add ar(i, 1), i
      Next
        p = aw.Path & "\"
        f = Dir(p & "*.xls")
        Do While f <> ""
          If f <> ThisWorkbook.Name Then
            Set wk = GetObject(p & f)
            ar2 = wk.Sheets(1).Range("e9:f29")
              Set c = aw.Sheets("汇总表").Range("d7:g7").Find(Left(wk.Name, Len(wk.Name) - 4))
                For i = 1 To UBound(ar2)
                  If d.exists(ar2(i, 1)) Then
                    ar(d(ar2(i, 1)), c.Column - 3) = ar2(i, 2)
                  End If
                Next
            wk.Close False
           End If
        f = Dir
        Loop
   aw.Sheets("汇总表").Range("d8:g28") = ar
 Application.ScreenUpdating = True
End Sub

 

Xizgxd0E.rar (9.1 KB, 下载次数: 92)

2008-10-5 20:07 上传

点击文件名下载附件

[此贴子已经被作者于2008-10-5 20:07:02编辑过]

martin_ykk

用外部引用+Vlookup就足够了，每次更新下链接就行了，用VBA写写还挺麻烦的

exc姜

学习中