多列数据汇总在本表中

njwtg

各位老师好，请问如何将多列数据汇总在本表中，谢谢

lsc900707

1. Sub gj23w98()
   
2.     Set d = CreateObject("scripting.dictionary")
   
3.      r = Columns("aa:an").Find(what:="*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row
   
4.      arr = Range("aa2:an" & r)
   
5.      ReDim brr(1 To UBound(arr), 1 To 2)
   
6.      For i = 1 To UBound(arr)
   
7.         For j = 1 To UBound(arr, 2) Step 2
   
8.             If Len(arr(i, j)) Then s = arr(i, j)
   
9.             If Not d.exists(s) Then
   
10.                 m = m + 1
    
11.                 d(s) = m
    
12.                 brr(m, 1) = arr(i, j)
    
13.                 brr(m, 2) = Val(arr(i, j + 1))
    
14.             Else
    
15.                 brr(d(s), 2) = brr(d(s), 2) + Val(arr(i, j + 1))
    
16.             End If
    
17.         Next
    
18.     Next
    
19.     If m Then
    
20.         Range("w2:x" & Rows.Count).ClearContents
    
21.         [w2].Resize(m, 2) = brr
    
22.     End If
    
23. End Sub

复制代码

lsc900707

测试参考附件：

njwtg

谢谢，非常完美

njwtg

这个程序还有点小问题，报错了，麻烦lsc900707老师看看，谢谢您

lsc900707

njwtg 发表于 2019-6-20 19:53
这个程序还有点小问题，报错了，麻烦lsc900707老师看看，谢谢您

1. Sub gj23w98()
   
2.     Dim brr(1 To 9999, 1 To 2)
   
3.     Set d = CreateObject("scripting.dictionary")
   
4.      r = Columns("aa:an").Find(what:="*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row
   
5.      arr = Range("aa2:an" & r)
   
6.      For j = 1 To UBound(arr, 2) Step 2
   
7.         For i = 1 To UBound(arr)
   
8.             If Len(arr(i, j)) Then s = arr(i, j)
   
9.             If Not d.exists(s) Then
   
10.                 m = m + 1
    
11.                 d(s) = m
    
12.                 brr(m, 1) = arr(i, j)
    
13.                 brr(m, 2) = Val(arr(i, j + 1))
    
14.             Else
    
15.                 brr(d(s), 2) = brr(d(s), 2) + Val(arr(i, j + 1))
    
16.             End If
    
17.         Next
    
18.     Next
    
19.     If m Then
    
20.         Range("w2:x" & Rows.Count).ClearContents
    
21.         [w2].Resize(m, 2) = brr
    
22.     End If
    
23. End Sub

复制代码

njwtg

可以，运行很好，谢谢了