[已解决]用VBA汇总结果保存总表 粉红色单元格

laoau138

用VBA汇总结果保存总表 粉红色单元格

最佳答案

月排行榜 / 总排行榜

五月初五

2017-3-28 19:43

1. Sub ff()
   
2.     Dim d, ar, i&, iget&, t$
   
3.     Dim sht As Worksheet
   
4.     Dim kr(1 To 65536, 1 To 6)
   
5.     Set d = CreateObject("scripting.dictionary")
   
6.     For Each sht In Sheets
   
7.         If sht.Name <> "總表" Then
   
8.             With sht
   
9.                 ar = .Range("a3", .Cells(Rows.Count, 6).End(3)).Value
   
10.             End With
    
11.             For i = LBound(ar) To UBound(ar)
    
12.                 t = ar(i, 1) & ar(i, 2)
    
13.                 If Len(t) Then
    
14.                     If Not d.exists(t) Then
    
15.                         k = k + 1: d(t) = k
    
16.                         Dim m%, n%
    
17.                         For m = 1 To 6
    
18.                             kr(k, m) = ar(i, m)
    
19.                         Next
    
20.                     Else
    
21.                         iget = d(t)
    
22.                         For n = 3 To 6
    
23.                             kr(iget, n) = kr(iget, n) + ar(i, n)
    
24.                         Next
    
25.                     End If
    
26.                 End If
    
27.             Next
    
28.         End If
    
29.     Next
    
30.     Range("a3", Cells(Rows.Count, 6).End(3)) = ""
    
31.     Range("a3:f3").Resize(k) = kr
    
32.     Set d = Nothing
    
33. End Sub
    

复制代码

跳转到最佳答案楼层

laoau138

谁来做一下

五月初五

1. Sub ff()
   
2.     Dim d, ar, i&, iget&, t$
   
3.     Dim sht As Worksheet
   
4.     Dim kr(1 To 65536, 1 To 6)
   
5.     Set d = CreateObject("scripting.dictionary")
   
6.     For Each sht In Sheets
   
7.         If sht.Name <> "總表" Then
   
8.             With sht
   
9.                 ar = .Range("a3", .Cells(Rows.Count, 6).End(3)).Value
   
10.             End With
    
11.             For i = LBound(ar) To UBound(ar)
    
12.                 t = ar(i, 1) & ar(i, 2)
    
13.                 If Len(t) Then
    
14.                     If Not d.exists(t) Then
    
15.                         k = k + 1: d(t) = k
    
16.                         Dim m%, n%
    
17.                         For m = 1 To 6
    
18.                             kr(k, m) = ar(i, m)
    
19.                         Next
    
20.                     Else
    
21.                         iget = d(t)
    
22.                         For n = 3 To 6
    
23.                             kr(iget, n) = kr(iget, n) + ar(i, n)
    
24.                         Next
    
25.                     End If
    
26.                 End If
    
27.             Next
    
28.         End If
    
29.     Next
    
30.     Range("a3", Cells(Rows.Count, 6).End(3)) = ""
    
31.     Range("a3:f3").Resize(k) = kr
    
32.     Set d = Nothing
    
33. End Sub
    

复制代码

laoau138

五月初五 发表于 2017-3-28 19:43

第一次见面高手