[已解决]如何写代码可以抓取同一文件夹下的指定列数据并进行汇总？

czl103 · 发表于 2017-7-10 11:15

本帖最后由 czl103 于 2017-7-10 14:49 编辑

如何写代码可以抓取同一文件夹下的指定列数据并进行汇总，结果只显示汇总。

如附件所示，每个文件都有各个员工的姓名、年龄、部门、金额，需要得到的结果为：
财务部：15003；
人事部：xxx;
销售部：yyy

谢谢大虾！

最佳答案

月排行榜 / 总排行榜

chart888

2017-7-10 14:16

czl103 发表于 2017-7-10 13:48
太牛了！　能麻烦高手大概解释下每行代码的意思么？不胜感激！

Private Sub CommandButton1_Click()
Dim MyPath$, MyName$, sh As Workbook, i&, Arr, Brr(1 To 100, 1 To 2) ' 定义变量
Set d = CreateObject("Scripting.Dictionary") '定义字典
On Error Resume Next '忽略错误
Application.ScreenUpdating = False '关闭屏幕刷新，提高速度
MyPath = ThisWorkbook.Path & "" '获得当前工作簿所在的地址
MyName = Dir(MyPath & "*.*") '获得文件夹内的文件名
Do While MyName <> "" '开始在文件夹内的文件中开始循环
If MyName <> ThisWorkbook.Name Then '文件名不等于当前工作簿时进行以下操作
Set sh = GetObject(MyPath & MyName) '打开工作簿
Arr = sh.ActiveSheet.Range("A1").CurrentRegion '将打开的工作簿A1单元格所在的区域放入数组
For i = 2 To UBound(Arr) '从数组的第二项开始循环，因为第一项为标题
If d.exists(Arr(i, 3)) Then '判断在不在字典内，如果在进行以下操作
k = d(Arr(i, 3)) '返回字典内的关键字所在的位置，也就是返回二维数组的行号
Brr(k, 2) = Brr(k, 2) + Arr(i, 4) '将关键字对应的项目求和
Else '如果字典内没有进行以下操作
m = m + 1 '定义一个新位置
d(Arr(i, 3)) = m '将这个关键放入新位置,可以理解为放入一个新的二维数组,m为数组的行号
Brr(m, 1) = Arr(i, 3) & "部:" '数组第一列为名称
Brr(m, 2) = Arr(i, 4) '数组第二列为对应的数据
End If
Workbooks(MyName).Close True '关闭打开的工作簿
Next
End If
MyName = Dir '获得下一个文件名
Loop
ThisWorkbook.ActiveSheet.Range("A1").Resize(UBound(Brr), 2) = Brr '将刚才的统计数据放在单元格内
End Sub

复制代码

字典数组不懂得话，估计也看不懂

跳转到最佳答案楼层

czl103 · 发表于 2017-7-10 12:20

自己顶一下

chart888 · 发表于 2017-7-10 12:52

Private Sub CommandButton1_Click()
Dim MyPath$, MyName$, sh As Workbook, i&, Arr, Brr(1 To 100, 1 To 2)
Set d = CreateObject("Scripting.Dictionary")
On Error Resume Next
Application.ScreenUpdating = False
MyPath = ThisWorkbook.Path & ""
MyName = Dir(MyPath & "*.*")
Application.ScreenUpdating = False
Do While MyName <> ""
If MyName <> ThisWorkbook.Name Then
Set sh = GetObject(MyPath & MyName)
Arr = sh.ActiveSheet.Range("A1").CurrentRegion
For i = 2 To UBound(Arr)
If d.exists(Arr(i, 3)) Then
k = d(Arr(i, 3))
Brr(k, 2) = Brr(k, 2) + Arr(i, 4)
Else
m = m + 1
d(Arr(i, 3)) = m
Brr(m, 1) = Arr(i, 3) & "部:"
Brr(m, 2) = Arr(i, 4)
End If
Workbooks(MyName).Close True
Next
End If
MyName = Dir
Loop
ThisWorkbook.ActiveSheet.Range("A1").Resize(UBound(Brr), 2) = Brr
End Sub

复制代码

czl103 · 发表于 2017-7-10 13:48

chart888 发表于 2017-7-10 12:52

太牛了！　能麻烦高手大概解释下每行代码的意思么？不胜感激！

chart888 · 发表于 2017-7-10 14:16

这个最佳答案由 chart888 给出，感谢 chart888 的回答。

单击隐藏图章

czl103 发表于 2017-7-10 13:48
太牛了！　能麻烦高手大概解释下每行代码的意思么？不胜感激！

Private Sub CommandButton1_Click()
Dim MyPath$, MyName$, sh As Workbook, i&, Arr, Brr(1 To 100, 1 To 2) ' 定义变量
Set d = CreateObject("Scripting.Dictionary") '定义字典
On Error Resume Next '忽略错误
Application.ScreenUpdating = False '关闭屏幕刷新，提高速度
MyPath = ThisWorkbook.Path & "" '获得当前工作簿所在的地址
MyName = Dir(MyPath & "*.*") '获得文件夹内的文件名
Do While MyName <> "" '开始在文件夹内的文件中开始循环
If MyName <> ThisWorkbook.Name Then '文件名不等于当前工作簿时进行以下操作
Set sh = GetObject(MyPath & MyName) '打开工作簿
Arr = sh.ActiveSheet.Range("A1").CurrentRegion '将打开的工作簿A1单元格所在的区域放入数组
For i = 2 To UBound(Arr) '从数组的第二项开始循环，因为第一项为标题
If d.exists(Arr(i, 3)) Then '判断在不在字典内，如果在进行以下操作
k = d(Arr(i, 3)) '返回字典内的关键字所在的位置，也就是返回二维数组的行号
Brr(k, 2) = Brr(k, 2) + Arr(i, 4) '将关键字对应的项目求和
Else '如果字典内没有进行以下操作
m = m + 1 '定义一个新位置
d(Arr(i, 3)) = m '将这个关键放入新位置,可以理解为放入一个新的二维数组,m为数组的行号
Brr(m, 1) = Arr(i, 3) & "部:" '数组第一列为名称
Brr(m, 2) = Arr(i, 4) '数组第二列为对应的数据
End If
Workbooks(MyName).Close True '关闭打开的工作簿
Next
End If
MyName = Dir '获得下一个文件名
Loop
ThisWorkbook.ActiveSheet.Range("A1").Resize(UBound(Brr), 2) = Brr '将刚才的统计数据放在单元格内
End Sub

复制代码

字典数组不懂得话，估计也看不懂

czl103 · 发表于 2017-7-10 14:49

chart888 发表于 2017-7-10 14:16
字典数组不懂得话，估计也看不懂

太感谢了大虾！

		自动登录	找回密码
密码			注册