按指定的顺序汇总求和

Jiessie.M

如图，A1：B6为源数据，姓名和销售件数。
E列是我指定的姓名顺序，我想在F列求出销售件数汇总。
请问用“数组+字典”方式如何做？（不要用Application.WorksheetFunction.SumIf）
谢谢！万分感谢！

例子.zip (13.87 KB, 下载次数: 35)

2018-11-2 15:16 上传

点击文件名下载附件

jy03342543

Sub Test()
Dim d As Object
Set d = CreateObject("scripting.dictionary")
Arr = Range("A1:B" & Cells(Rows.Count, 1).End(xlUp).Row)
For I = 1 To UBound(Arr)
    d.Item(Arr(I, 1)) = d.Item(Arr(I, 1)) + Arr(I, 2)
Next
[E1].Resize(d.Count) = Application.Transpose(d.keys)
[F1].Resize(d.Count) = Application.Transpose(d.items)
End Sub

Jiessie.M

jy03342543 发表于 2018-11-2 15:22
Sub Test()
Dim d As Object
Set d = CreateObject("scripting.dictionary")

谢谢。可是“孙七”这个人在数据源中没有，用您的语句，自动将“孙七”删了。
能不能发现没有的人，自动补0，然后找下一个？
谢谢

一把小刀闯天下

Option Explicit

Sub zz()
  Dim arr, brr, i, dic, n
  Set dic = CreateObject("scripting.dictionary")
  arr = [a1].CurrentRegion
  For i = 1 To UBound(arr, 1)
    If dic.exists(arr(i, 1)) Then
      arr(dic(arr(i, 1)), 2) = arr(dic(arr(i, 1)), 2) + arr(i, 2)
    Else
      n = n + 1: arr(n, 1) = arr(i, 1): arr(n, 2) = arr(i, 2)
      dic(arr(i, 1)) = n
    End If
  Next
  brr = [e1].CurrentRegion
  If IsArray(brr) Then '
    For i = 1 To UBound(brr, 1)
      If Not dic.exists(brr(i, 1)) Then
        n = n + 1: arr(n, 1) = brr(i, 1)
        arr(n, 2) = IIf(Len(brr(i, 2)) = 0, 0, brr(i, 2))
      End If
    Next
  End If
  With [e1]
    .Resize(Rows.Count, 2).ClearContents
    .Resize(n, 2) = arr
  End With
End Sub

xrs08234

Jiessie.M 发表于 2018-11-2 15:27
谢谢。可是“孙七”这个人在数据源中没有，用您的语句，自动将“孙七”删了。
能不能发现没有的人，自动 ...

试试
Sub zz()
    Dim ar1, ar2, d As Object
    Dim i As Long
    Application.ScreenUpdating = False
    Set d = CreateObject("Scripting.Dictionary")
    Range("F1:F" & Range("F65536").End(xlUp).Row).ClearContents
    ar1 = Range("E1:E" & Range("E65536").End(xlUp).Row)
    For i = 1 To UBound(ar1)
      d(ar1(i, 1)) = 0
    Next i
     ar2 = Range("A1:B" & Range("A65536").End(xlUp).Row)
     For i = 1 To UBound(ar2)
       If d.exists(ar2(i, 1)) Then
        d.Item(ar2(i, 1)) = d.Item(ar2(i, 1)) + ar2(i, 2)
       End If
      Next i
      [F1].Resize(d.Count) = Application.Transpose(d.items)
     Set d = Nothing
   
    Application.ScreenUpdating = True
End Sub

719404338

1. Sub t()
   
2. Dim d, i%
   
3. Set d = CreateObject("scripting.dictionary")
   
4. For i = 1 To [a65536].End(3).Row
   
5. d(Range("a" & i).Value) = d(Range("a" & i).Value) + Range("b" & i)
   
6. Next i
   
7. For i = 1 To [e65536].End(3).Row
   
8. Range("f" & i) = d(Range("e" & i).Value)
   
9. If Range("f" & i) = "" Then Range("f" & i) = 0
   
10. Next i
    
11. End Sub

复制代码

yaozong

Jiessie.M 发表于 2018-11-2 15:27
谢谢。可是“孙七”这个人在数据源中没有，用您的语句，自动将“孙七”删了。
能不能发现没有的人，自动 ...

1. Sub yyy()
   
2.   Dim d, arr, brr, i&
   
3.   Set d = CreateObject("Scripting.Dictionary")
   
4.   arr = [a1].CurrentRegion.Value
   
5.   brr = Range("f1", [e65536].End(3)).Value
   
6.   For i = 1 To UBound(arr)
   
7.     d(arr(i, 1)) = d(arr(i, 1)) + arr(i, 2)
   
8.   Next
   
9.   For i = 1 To UBound(brr)
   
10.     brr(i, 2) = d(brr(i, 1)) + 0
    
11.   Next
    
12.   [e1].Resize(UBound(brr), 2) = brr
    
13. End Sub

复制代码

zhangcheng6688

yaozong 发表于 2018-11-2 20:28

Dictionary

乐乐2006201505

Sub sumifs计提求和()
    Sheets(1).Range("f1:f" & Range("e65536").End(3).Row).ClearContents
    arr1 = Sheets(1).Range("a1:b" & Range("a65536").End(3).Row)
    Set d = CreateObject("scripting.dictionary")
    For j = 1 To UBound(arr1)
        d(arr1(j, 1)) = d(arr1(j, 1)) + arr1(j, 2)
    Next j
    For j = 1 To 1
        arr2 = Sheets(j).Range("e1:f" & Range("e65536").End(3).Row)
        For i = 1 To Sheets(j).Range("e65536").End(3).Row
            arr2(i, 2) = arr2(i, 2) + d(arr2(i, 1))
        Next i
        Sheets(j).Range("e1:f" & Range("e65536").End(3).Row) = arr2
    Next j
End Sub

zhangcheng6688

学习一下字典，打扰
Sub test()
arr = [a1].CurrentRegion
lastr = Cells(Rows.Count, "e").End(xlUp).Row
brr = Range("e1:f" & lastr)
Set d = CreateObject("scripting.dictionary")
For i = 1 To UBound(arr)
   d(arr(i, 1)) = d(arr(i, 1)) + arr(i, 2)
Next
For j = 1 To UBound(brr)
   If d.exists(brr(j, 1)) Then
      brr(j, 2) = d(brr(j, 1))
   Else
      brr(j, 2) = 0
   End If
Next
[e1].Resize(UBound(brr), UBound(brr, 2)) = brr
End Sub