求助！字典多列分别求和

weskerlu

第一列是人名，后面有六列数据
求用字典的方法，求出每个人，每列数据的总和
如sheet2里的样子，每个人只占一行
详情见附件
除了字典？是有还有更好的方法？
新人不太会，望大师指教
谢谢

一把小刀闯天下

'首选应该使用字典。不用字典来个，当数据量大时换快排

Option Explicit

Sub test()
  Dim arr, i, j, k, t, m, sum
  arr = Sheets("sheet1").[a1].CurrentRegion.Offset(2)
  For i = 1 To UBound(arr, 1) - 3
    For j = i + 1 To UBound(arr, 1) - 2
      If StrComp(arr(i, 1), arr(j, 1), vbTextCompare) = 1 Then
        For k = 1 To UBound(arr, 2)
          t = arr(i, k): arr(i, k) = arr(j, k): arr(j, k) = t
        Next
      End If
  Next j, i
  ReDim sum(2 To UBound(arr, 2))
  For i = 1 To UBound(arr, 1) - 2
    For j = 2 To UBound(arr, 2)
      If Len(arr(i, j)) Then sum(j) = sum(j) + arr(i, j)
    Next
    If arr(i, 1) <> arr(i + 1, 1) Then
      m = m + 1: arr(m, 1) = arr(i, 1)
      For j = 2 To UBound(arr, 2): arr(m, j) = sum(j): Next
      ReDim sum(2 To UBound(arr, 2))
    End If
  Next
  With Sheets("sheet2").[a3]
    .Resize(Rows.Count - 3, UBound(arr, 2)).ClearContents
    .Resize(m, UBound(arr, 2)) = arr
  End With
End Sub

weskerlu

一把小刀闯天下 发表于 2019-6-10 22:36
'首选应该使用字典。不用字典来个，当数据量大时换快排

Option Explicit

非常感谢，我先试着读一下，看看能看懂不

weskerlu

一把小刀闯天下 发表于 2019-6-10 22:36
'首选应该使用字典。不用字典来个，当数据量大时换快排

Option Explicit

非常感谢，又学到新东西了，我先试试能读懂

网海遨游

你这个问题，还是用字典简洁快速。
　

1. Sub test()
   
2.     Set sh1 = Sheets("sheet1")
   
3.     Set sh2 = Sheets("sheet2")
   
4.     sh2.Range("a3:g" & 1000).ClearContents
   
5.     r = sh1.[a65536].End(3).Row
   
6.     Set d = CreateObject("Scripting.Dictionary")
   
7.     arr = sh1.Range("a3:g" & r)
   
8.     For j = 2 To UBound(arr, 2)
   
9.         For i = 1 To UBound(arr)
   
10.            d(arr(i, 1)) = d(arr(i, 1)) + arr(i, j)
    
11.         Next i
    
12.         If j = 2 Then sh2.[a3].Resize(d.Count, 1) = Application.Transpose(d.keys)
    
13.         sh2.Cells(3, j).Resize(d.Count, 1) = Application.Transpose(d.items)
    
14.         d.RemoveAll
    
15.     Next j
    
16. End Sub

复制代码

DevilW

字典记录新数组位置，由新数组累加数据

1. Sub test()
   
2.     ar = Sheet1.Range("a3:g" & [a65536].End(3).Row)
   
3.     ReDim br(1 To UBound(ar), 1 To 7)
   
4.     Set d = CreateObject("scripting.dictionary")
   
5.     For i = 1 To UBound(ar)
   
6.         s = ar(i, 1)
   
7.         If Not d.exists(s) Then d(s) = d.Count + 1
   
8.         br(d(s), 1) = s
   
9.         For j = 2 To 7
   
10.             br(d(s), j) = br(d(s), j) + ar(i, j)
    
11.         Next
    
12.     Next
    
13.     Sheet2.[a3].Resize(d.Count, 7) = br
    
14.     Set d = Nothing
    
15. End Sub

复制代码

wdx223

1. Sub test()
   
2. 
   
3. With CreateObject("ADODB.Connection")
   
4.     .Open "provider=microsoft.ace.oledb.12.0;extended properties='excel 12.0;HDR=No';data source=" & ThisWorkbook.FullName
   
5.     Worksheets("Sheet2").[A3].CopyFromRecordset .Execute("select f1,sum(f2),sum(f3),sum(f4),sum(f5),sum(f6),sum(f7) from [Sheet1$A3:G10000] group by f1")
   
6. End With
   
7. 
   
8. End Sub
   

复制代码

fanyoulin

我曾看过论坛高手 L （抱歉我记不住他ID）写过用类实现字典一对多的范例，后来我用数组也实现了类似的功能。上楼是用字典来记录数组的位置，可以直接在字典中记录多列参数，我认为理解起来更简单：

Dim zd
Set zd = CreateObject("scripting.dictionary")
Dim arr1(1 To 7)
Dim arr2
For i = 3 To [a1000].End(3).Row
    arr1(1) = Cells(i, 1)
    arr1(2) = Cells(i, 2)
    arr1(3) = Cells(i, 3)
    arr1(4) = Cells(i, 4)
    arr1(5) = Cells(i, 5)
    arr1(6) = Cells(i, 6)
    arr1(7) = Cells(i, 7)
    If zd.exists(Trim(Cells(i, 1))) Then  '对已存在的字典进行求和，然后再重新写入字典
       arr2 = zd.Item(Cells(i, 1).Value)
       arr1(2) = arr1(2) + arr2(2)
       arr1(3) = arr1(3) + arr2(3)
       arr1(4) = arr1(4) + arr2(4)
       arr1(5) = arr1(5) + arr2(5)
       arr1(6) = arr1(6) + arr2(6)
       arr1(7) = arr1(7) + arr2(7)
    End If
    zd(Cells(i, 1).Value) = arr1   '将数组写入字典
Next i
Dim arr3
arr3 = zd.keys
s = 3
For i = 0 To UBound(arr3)     '填充结果
    Worksheets("sheet2").Range(Worksheets("sheet2").Cells(s, 1), Worksheets("sheet2").Cells(s, 7)) = zd(arr3(i))   
    s = s + 1
Next i

vic9

Sub ere()
Dim arr, i, d, k, s, n
Set d = CreateObject("scripting.dictionary")
arr = Sheets("sheet1").Range("a1:g11")
ReDim brr(1 To 9, 1 To 7)
    For i = 3 To UBound(arr)
     For n = 2 To UBound(arr, 2)
        If Not d.exists(arr(i, 1)) Then
            k = k + 1
            d(arr(i, 1)) = k
            brr(k, 1) = arr(i, 1)
            brr(k, n) = arr(i, n)
        Else
            brr(d(arr(i, 1)), n) = brr(d(arr(i, 1)), n) + arr(i, n)
        End If
        Next
    Next
    Sheets("sheet2").[a3].Resize(UBound(brr), UBound(brr, 2)) = brr
End Sub

zymwhy

字典计数+数组，参考一下。

Sub test1()
Dim arr, brr, i, m, n, t
Dim d As Object
Set d = CreateObject("scripting.dictionary")
With Sheets("Sheet1")
arr = .Range("a3:g" & .Cells(.Rows.Count, 1).End(xlUp).Row)
ReDim brr(1 To UBound(arr), 1 To 7)
For i = 1 To UBound(arr)
    If Not d.exists(arr(i, 1)) Then
        k = k + 1
        d(arr(i, 1)) = k
        For n = 1 To 7
            brr(k, n) = arr(i, n)
        Next
    Else
        t = d(arr(i, 1))
        For m = 2 To 7
            brr(t, m) = brr(t, m) + arr(i, m)
        Next
    End If
Next
End With
Sheets("Sheet2").[a3].Resize(k, 7) = brr
End Sub