[已解决]请高手编写个VBA汇总，要求在“问题”文件中，谢谢！！！

qdzbk

汇总.rar (5.78 KB, 下载次数: 23)

2012-8-16 22:15 上传

点击文件名下载附件
最好用数组与字典结合的方法来统计，因统计的数据很多，谢谢老师帮助！
盼高手早日出现。

最佳答案

月排行榜 / 总排行榜

柳如烟

2012-8-16 23:49

qdzbk 发表于 2012-8-16 23:28
只有二个文件，但二个文件中的记录有很多。

1. 
   
2. Sub 统计()
   
3.     Dim arr, arr1(), d, i&, j%, k%, mypath$, b As Boolean
   
4.     Set d = CreateObject("scripting.dictionary")
   
5.     mypath = ThisWorkbook.Path & ""
   
6.     Application.ScreenUpdating = False
   
7.     Application.DisplayAlerts = False
   
8.     On Error Resume Next
   
9.     Workbooks("表1.xls").Activate
   
10.     Workbooks.Open mypath & "表1.xls"
    
11.     arr = Range("a2:f" & Range("a65536").End(3).Row)
    
12.     If Err <> 0 Then
    
13.         ActiveWorkbook.Close
    
14.         Err.Clear
    
15.     End If
    
16.     For i = 1 To UBound(arr)
    
17.         If Not d.exists(Left(arr(i, 1), 2)) Then
    
18.             k = k + 1
    
19.             d(Left(arr(i, 1), 2)) = k
    
20.             ReDim Preserve arr1(1 To 7, 1 To k)
    
21.             arr1(1, k) = Left(arr(i, 1), 2)
    
22.         End If
    
23.         If Left(arr(i, 2), 2) = Left(arr(i, 1), 2) Then
    
24.             For j = 3 To UBound(arr, 2)
    
25.                 arr1(2, d(Left(arr(i, 1), 2))) = arr1(2, d(Left(arr(i, 1), 2))) + arr(i, j)
    
26.             Next
    
27.         Else
    
28.             For j = 3 To UBound(arr, 2)
    
29.                 arr1(j, d(Left(arr(i, 1), 2))) = arr1(j, d(Left(arr(i, 1), 2))) + arr(i, j)
    
30.             Next
    
31.         End If
    
32.     Next
    
33.     Workbooks("表2.xls").Activate
    
34.     Workbooks.Open mypath & "表2.xls"
    
35.     arr = Range("a2:f" & Range("a65536").End(3).Row)
    
36.     If Err <> 0 Then ActiveWorkbook.Close
    
37.     For i = 1 To UBound(arr)
    
38.         arr1(7, d(Left(arr(i, 1), 2))) = arr1(7, d(Left(arr(i, 1), 2))) + arr(i, 3)
    
39.     Next
    
40.     ThisWorkbook.Activate
    
41.     Range("a:a").NumberFormat = "@"
    
42.     With Range("a3").Resize(k, 7)
    
43.         .ClearContents
    
44.         .Value = Application.Transpose(arr1)
    
45.     End With
    
46.     Application.DisplayAlerts = True
    
47.     Application.ScreenUpdating = True
    
48. End Sub
    

复制代码

点击"统计"按钮就可以了。

跳转到最佳答案楼层

梅一枝

请修改一下问题或数据源可以吗？谁跟谁怎么弄请明确。

柳如烟

要汇总的文件只有表1和表2吗？还是要汇总的文件有很多个？

qdzbk

梅一枝 发表于 2012-8-16 22:46
请修改一下问题或数据源可以吗？谁跟谁怎么弄请明确。

统计条件是按“问题”文件的A3和A4来统计。
统计的数据源是表1和表2
统计出来的数据存放在“问题”文件的B3至G4区域

就是说：按“问题”文件的A3和A4中的值为条件，到“表1”和“表2”中去统计，统计结果应是下表红色数据

编号	进库	出库数据1	出库数据2	出库数据3	出库数据4	出库数据5
01	704	70	6	143	85	121
02	5973	149	103	227	70	104

qdzbk

柳如烟 发表于 2012-8-16 22:56
要汇总的文件只有表1和表2吗？还是要汇总的文件有很多个？

只有二个文件，但二个文件中的记录有很多。

柳如烟

qdzbk 发表于 2012-8-16 23:28
只有二个文件，但二个文件中的记录有很多。

1. 
   
2. Sub 统计()
   
3.     Dim arr, arr1(), d, i&, j%, k%, mypath$, b As Boolean
   
4.     Set d = CreateObject("scripting.dictionary")
   
5.     mypath = ThisWorkbook.Path & ""
   
6.     Application.ScreenUpdating = False
   
7.     Application.DisplayAlerts = False
   
8.     On Error Resume Next
   
9.     Workbooks("表1.xls").Activate
   
10.     Workbooks.Open mypath & "表1.xls"
    
11.     arr = Range("a2:f" & Range("a65536").End(3).Row)
    
12.     If Err <> 0 Then
    
13.         ActiveWorkbook.Close
    
14.         Err.Clear
    
15.     End If
    
16.     For i = 1 To UBound(arr)
    
17.         If Not d.exists(Left(arr(i, 1), 2)) Then
    
18.             k = k + 1
    
19.             d(Left(arr(i, 1), 2)) = k
    
20.             ReDim Preserve arr1(1 To 7, 1 To k)
    
21.             arr1(1, k) = Left(arr(i, 1), 2)
    
22.         End If
    
23.         If Left(arr(i, 2), 2) = Left(arr(i, 1), 2) Then
    
24.             For j = 3 To UBound(arr, 2)
    
25.                 arr1(2, d(Left(arr(i, 1), 2))) = arr1(2, d(Left(arr(i, 1), 2))) + arr(i, j)
    
26.             Next
    
27.         Else
    
28.             For j = 3 To UBound(arr, 2)
    
29.                 arr1(j, d(Left(arr(i, 1), 2))) = arr1(j, d(Left(arr(i, 1), 2))) + arr(i, j)
    
30.             Next
    
31.         End If
    
32.     Next
    
33.     Workbooks("表2.xls").Activate
    
34.     Workbooks.Open mypath & "表2.xls"
    
35.     arr = Range("a2:f" & Range("a65536").End(3).Row)
    
36.     If Err <> 0 Then ActiveWorkbook.Close
    
37.     For i = 1 To UBound(arr)
    
38.         arr1(7, d(Left(arr(i, 1), 2))) = arr1(7, d(Left(arr(i, 1), 2))) + arr(i, 3)
    
39.     Next
    
40.     ThisWorkbook.Activate
    
41.     Range("a:a").NumberFormat = "@"
    
42.     With Range("a3").Resize(k, 7)
    
43.         .ClearContents
    
44.         .Value = Application.Transpose(arr1)
    
45.     End With
    
46.     Application.DisplayAlerts = True
    
47.     Application.ScreenUpdating = True
    
48. End Sub
    

复制代码

点击"统计"按钮就可以了。

梅一枝

前辈给您回复的代码 可以实现您效果吗？如果满意请评最佳答案谢谢

chuangxin_sun