想用VBA编码实现countifs条件计数

ykcbf1100

参与一下。。。

ykcbf1100

代码供参考。。。

1. Sub ykcbf()   '//2024.2.5
   
2.     Dim arr, d
   
3.     Application.ScreenUpdating = False
   
4.     Set d = CreateObject("Scripting.Dictionary")
   
5.     With Sheets("数据源")
   
6.         r = .Cells(.Rows.Count, "a").End(xlUp).Row
   
7.         arr = .[a1].Resize(r, 2)
   
8.     End With
   
9.     For i = 2 To UBound(arr)
   
10.         s = arr(i, 2) & "|" & arr(i, 1)
    
11.         d(s) = d(s) + 1
    
12.     Next
    
13.     With Sheets("要实现的")
    
14.         r = .Cells(.Rows.Count, "a").End(xlUp).Row
    
15.         arr = .[a1].Resize(r, 6)
    
16.         For i = 2 To UBound(arr)
    
17.             For j = 2 To UBound(arr, 2)
    
18.                 s = arr(i, 1) & "|" & arr(1, j)
    
19.                 If d.Exists(s) Then
    
20.                     arr(i, j) = d(s)
    
21.                 End If
    
22.             Next
    
23.         Next
    
24.         .[a1].Resize(r, 6) = arr
    
25.     End With
    
26.     Set d = Nothing
    
27.     Application.ScreenUpdating = True
    
28.     MsgBox "OK！"
    
29. End Sub
    
30. 
    

复制代码

FredericChan

也可以使用SQL查询语句：

1. Sub modTest()
   
2. 
   
3.     Dim cnn As Object, rs As Object, myFile, sqlstr
   
4.     Application.ScreenUpdating = False
   
5.    
   
6.     myFile = ThisWorkbook.FullName
   
7.     Set cnn = CreateObject("ADODB.Connection"): Set rs = CreateObject("ADODB.Recordset")
   
8.     cnn.Open "Provider=Microsoft.Ace.OLEDB.12.0;Extended properties='Excel 12.0 Xml;Hdr=yes;IMEX=1';data source=" & myFile
   
9.         sqlstr = "Select [日期], Sum(iif([种类]='A',1,0)), Sum(iif([种类]='B',1,0)), Sum(iif([种类]='C',1,0)), Sum(iif([种类]='D',1,0)), Sum(iif([种类]='E',1,0))" _
   
10.                 & " From [数据源$]" _
    
11.                 & " Group By [日期]"
    
12.                     
    
13.     With ThisWorkbook.Sheets("要实现的")
    
14.         .Range("A1:F1") = Array("日期", "A", "B", "C", "D", "E")
    
15.         .Range("A2:F" & .Rows.Count).ClearContents
    
16.         .Range("A2").CopyFromRecordset cnn.Execute(sqlstr)
    
17.         cnn.Close
    
18.         ThisWorkbook.Save
    
19.     End With
    
20.    
    
21.     Set cnn = Nothing
    
22.     Application.ScreenUpdating = True
    
23.     MsgBox "Done!", vbOKOnly, "Note"
    
24. End Sub

复制代码

lhj5286

参与一下，看能否满足楼主需求