vba双条件统计

hnzz416cxm

请教大师们vba双条件统计汇总，详见附件

hnzz416cxm

送鲜花送鲜花送鲜花送鲜花送鲜花

02761752696

hnzz416cxm 发表于 2022-12-22 16:26
送鲜花送鲜花送鲜花送鲜花送鲜花

看了文件，不明白要做什么
帮顶一下
关于求助贴的答复效率与发帖规范

liulang0808

标题对不上啊

LIUZHU

WPS做的，JS宏

LIUZHU

附件在此，用WPS打开测试

gwjkkkkk

请楼主参考附件。。。

sunya_0529

增加一个worksheet_change()事件，输入条件后回车即可输出查询——

1. 
   
2. <div>Option Explicit
   
3. 
   
4. Private Sub Worksheet_Change(ByVal Target As Range)
   
5. Select Case Target.Address
   
6.   Case "$T$3"
   
7.     Call QueryData(Target.Value)
   
8.   Case "$U$3"
   
9.     Call QueryData(Target.Offset(0, -1).Value, Target.Value)
   
10.   Case Else
    
11.     Exit Sub
    
12. End Select
    
13. End Sub
    
14. 
    
15. Sub QueryData(wwlw As String, Optional jtbh As String)
    
16. Dim wstDB As Worksheet, dic As Object, d
    
17. Dim c As Range, s$, arrDB, arrRT, i%, j%, k%
    
18. Set wstDB = Sheets("数据表")
    
19. Set dic = CreateObject("SCRIPTING.DICTIONARY")
    
20. With ActiveSheet.[C3:R3]
    
21.   For Each c In .Cells
    
22.     If Application.CountIf(wstDB.Rows(6), c.Value) = 0 Then '检查字段名称，将与[数据表$]中对不上的列出来
    
23.       s = s & c.Value & "、"
    
24.     Else '将字段名对应[数据表$]中的列号存入字典备用
    
25.       dic.Add c.Value, Application.Match(c.Value, wstDB.Rows(6), 0)
    
26.     End If
    
27.   Next
    
28. End With
    
29. If Len(s) > 0 Then
    
30.   MsgBox "下列字段名称无法与[数据表$]中的表头相匹配，请检查！" & vbCrLf & s, vbCritical
    
31.   Exit Sub
    
32. End If
    
33. arrDB = wstDB.Range("A8:AY" & wstDB.[B8].End(xlDown).Row)
    
34. ReDim arrRT(Application.CountIf(wstDB.Columns(27), wwlw), dic.Count)
    
35. d = dic.items
    
36. For i = 1 To UBound(arrDB)
    
37.   If arrDB(i, 27) = wwlw And IIf(Len(jtbh) > 0, arrDB(i, 28) = jtbh, True) Then
    
38.     arrRT(k, 0) = k + 1 '序号
    
39.     For j = 0 To UBound(d)
    
40.       arrRT(k, j + 1) = arrDB(i, d(j))
    
41.     Next j
    
42.     k = k + 1
    
43.   End If
    
44. Next i
    
45. With ActiveSheet
    
46.   .[B4:R65536].ClearContents
    
47.   If arrRT(0, 0) > 0 Then
    
48.     .[B4].Resize(UBound(arrRT, 1) + 1, UBound(arrRT, 2) + 1) = arrRT
    
49.   Else
    
50.     MsgBox "没有查找到任何记录，请修改查询条件！", vbCritical
    
51.   End If
    
52. End With
    
53. Set wstDB = Nothing
    
54. End Sub</div>

复制代码