根据两个条件，做数据统计，并填入对应单元格。

today77

同一个表下有2个sheet，“sheet1”与“数据”，
1、其中“sheet1”中的B列与“数据”中的L列是对应的；
2、“sheet1”中的E1、F1、G1与“数据”中的D列是对应的；
3、需要按着这两个对应条件，统计出sheet1中对象在“数据”中对应的数量“合计”，填入E、F、G对应单元格内，
4、sheet1中B列数据是固定的，不能修改。




表格函数特别卡，想试试VBA，字典能实现但是B列也会跟着变不知道应该怎么处理。请老师帮助写一下代码，感谢。

ykcbf1100

字典，附件供参考。。。

ykcbf1100

统计。。。

1. Sub ykcbf()   '//2024.7.18  统计
   
2.     Application.ScreenUpdating = False
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     With Sheets("数据")
   
5.         r = .Cells(Rows.Count, "d").End(3).Row
   
6.         arr = .[a1].Resize(r, 12)
   
7.     End With
   
8.     For i = 2 To UBound(arr)
   
9.         s = CStr(arr(i, 12)) & "|" & arr(i, 4)
   
10.         d(s) = d(s) + 1
    
11.     Next
    
12.     With Sheets("Sheet1")
    
13.         r = .Cells(Rows.Count, "d").End(3).Row
    
14.         arr = .[a1].Resize(r, 8)
    
15.         For i = 2 To UBound(arr)
    
16.             Sum = 0
    
17.             For j = 5 To 7
    
18.                 s = arr(i, 2) & "|" & arr(1, j)
    
19.                 If d.exists(s) Then
    
20.                     arr(i, j) = d(s)
    
21.                 End If
    
22.                 Sum = Sum + arr(i, j)
    
23.             Next
    
24.             arr(i, 8) = Sum
    
25.         Next
    
26.         .Columns(2).NumberFormatLocal = "@"
    
27.         .[a1].Resize(r, 8) = arr
    
28.     End With
    
29.     Set d = Nothing
    
30.     Application.ScreenUpdating = True
    
31.     MsgBox "OK！"
    
32. End Sub
    

复制代码

kyxfyzg

Sub test()
Set d = CreateObject("scripting.dictionary")
arr = Worksheets("数据").Range("a1").CurrentRegion
brr = Worksheets("Sheet1").Range("a1").CurrentRegion
crr = Worksheets("Sheet1").Range("e1:h" & UBound(brr))
For i = 2 To UBound(arr)
    s = arr(i, 4) & arr(i, 12)
    If d.Exists(s) Then
        d(s) = d(s) + 1
    Else
        d(s) = 1
    End If
Next i
For i = 2 To UBound(brr)
    For j = 1 To 3
        ss = brr(1, 4 + j) & brr(i, 2)
        If d.Exists(ss) Then
            crr(i, j) = d(ss)
        Else
            crr(i, j) = 0
        End If
    Next j
    crr(i, 4) = crr(i, 1) + crr(i, 2) + crr(i, 3)
Next i
Worksheets("Sheet1").Range("e1").Resize(UBound(crr), 4) = crr
End Sub

sdytsxd991122

today77

ykcbf1100 发表于 2024-7-18 11:56
统计。。。

感谢老师，学习了。

saghj

sxbjzjf110

lushang2018

1. Sub 测试()
   
2.     Dim i%, j%, k%, m%, n%, arr, brr, crr, drr
   
3.     Dim dic As Object, key, keys, items
   
4.     Set dic = CreateObject("scripting.dictionary")
   
5.     arr = Sheet2.Range("A1").CurrentRegion
   
6.     For i = 2 To UBound(arr)
   
7.         key = arr(i, 12)
   
8.         If Not dic.Exists(key) Then
   
9.             ReDim brr(1 To 5)
   
10.             brr(1) = key
    
11.             If arr(i, 4) = "字段1" Then
    
12.                 brr(2) = 1
    
13.             ElseIf arr(i, 4) = "字段2" Then
    
14.                 brr(3) = 1
    
15.             ElseIf arr(i, 4) = "字段3" Then
    
16.                 brr(4) = 1
    
17.             End If
    
18.             brr(5) = brr(2) + brr(3) + brr(4)
    
19.             dic(key) = brr
    
20.         Else
    
21.             brr = dic(key)
    
22.             If arr(i, 4) = "字段1" Then
    
23.                 brr(2) = brr(2) + 1
    
24.             ElseIf arr(i, 4) = "字段2" Then
    
25.                 brr(3) = brr(3) + 1
    
26.             ElseIf arr(i, 4) = "字段3" Then
    
27.                 brr(4) = brr(4) + 1
    
28.             End If
    
29.             brr(5) = brr(2) + brr(3) + brr(4)
    
30.             dic(key) = brr
    
31.         End If
    
32.     Next
    
33.     keys = dic.keys
    
34.     Sheet1.Cells(2, 5).Resize(10000, 3).ClearContents
    
35.     For i = 2 To Sheet1.Cells(Rows.Count, "A").End(xlUp).Row
    
36.         key = Sheet1.Cells(i, 2)
    
37.         brr = dic(key)
    
38.         For j = 2 To 5
    
39.             Sheet1.Cells(i, j + 3) = brr(j)
    
40.         Next
    
41.     Next
    
42. End Sub

复制代码

lushang2018

试一试，试一试