用VBA字典进行多条件查询匹配

somebody_1013

字典示范求助.rar (112.41 KB, 下载次数: 154)

2014-10-30 16:50 上传

点击文件名下载附件
求助

请问版主老师，如何可以利用字典进行多条件求和汇总匹配，详情见附件，sheet1为输入，sheet2为希望得到的输出，汇总求和项为sheet1的C列。期待您的答复

blanksoul12

留個位置,近來學字典中.

guojianlin1985

这样？

somebody_1013

guojianlin1985 发表于 2014-10-30 17:11
这样？

对的，跪求赐教

zax010

Sub zz()
    Dim d, arr
    Set d = CreateObject("Scripting.Dictionary")
    Application.ScreenUpdating = False
    arr = Sheet1.Range("a1").CurrentRegion
    For i = 2 To UBound(arr)
        d(arr(i, 1) & arr(i, 2)) = d(arr(i, 1) & arr(i, 2)) + arr(i, 3)
    Next
    With Sheet2
        For i = 2 To .[a1048576].End(3).Row
            For j = 2 To 10
                .Cells(i, j) = d(.Cells(i, 1).Value & .Cells(1, j).Value)
            Next
        Next
    End With
    Application.ScreenUpdating = True
End Sub

zax010

>>>>>>>>>>>>>>>>>>>>>
字典示范求助.rar (118.89 KB, 下载次数: 578)

2014-10-30 18:45 上传

点击文件名下载附件

guojianlin1985

透视表即可，何必字典？

blanksoul12

請問如果要用字典來做,可以怎做呢?

kszcs

zax010 发表于 2014-10-30 18:46
>>>>>>>>>>>>>>>>>>>>>

谢谢zax010老师的杰作！
文件夹内的数据能达到这样的效果吗（日期纵向排列，单位名称横向排放）

sdong7

1. Sub tt() 'bysdong7 20141031
   
2. Dim mxr1, mxr2 As Long
   
3. Dim arr1, arr2, dic, arr3(1 To 1000000, 1 To 2)
   
4. Set dic = CreateObject("scripting.dictionary")
   
5. mxr1 = Sheets("sheet1").[a1048576].End(xlUp).Row
   
6. mxr2 = Sheets("sheet2").[a1048576].End(xlUp).Row
   
7. arr1 = Sheets("sheet1").Range("a1:c" & mxr1)
   
8. arr2 = Sheets("sheet2").Range("a1:j" & mxr2)
   
9. On Error Resume Next
   
10. For i = 2 To mxr1
    
11. If dic.exists(arr1(i, 1) & arr1(i, 2)) Then
    
12. hang = dic(arr1(i, 1) & arr1(i, 2))
    
13. arr3(hang, 2) = arr3(hang, 2) + arr1(i, 3)
    
14. 
    
15. Else
    
16. k = k + 1
    
17. dic(arr1(i, 1) & arr1(i, 2)) = k
    
18. arr3(k, 1) = arr1(i, 1) & arr1(i, 2)
    
19. arr3(k, 2) = arr1(i, 3)
    
20. End If
    
21. Next i
    
22. 
    
23. For i = 2 To mxr2
    
24. For j = 2 To 10
    
25. 
    
26. m = dic(arr2(i, 1) & arr2(1, j))
    
27. 
    
28. arr2(i, j) = arr3(m, 2)
    
29. 
    
30. Next j
    
31. Next i
    
32. Sheets("sheet2").Range("a1:j" & mxr2) = arr2
    
33. 
    
34. 
    
35. End Sub
    

复制代码