求VBA代码

vba789

求助.rar (6.3 KB, 下载次数: 13)

2020-2-6 20:52 上传

点击文件名下载附件

具体要求看附件

liulang0808

http://club.excelhome.net/thread-1385473-1-1.html
字典的案例，楼主可以参考下，如果有问题，再说明吧

伱幹什仫啊伱

这个用公式比VBA简单
=COUNTIFS(Sheet2!$A$2:$A$23,Sheet1!$A3,Sheet2!$C$2:$C$23,Sheet1!B$2)

vba789

伱幹什仫啊伱 发表于 2020-2-6 22:36
这个用公式比VBA简单
=COUNTIFS(Sheet2!$A$2:$A$23,Sheet1!$A3,Sheet2!$C$2:$C$23,Sheet1!B$2)

谢谢，可能是我没表达清楚，意思就是求各小组分别有多少个男性，多少个女性

NadrsSaber

1. Option Explicit
   
2. 
   
3. Sub test()
   
4. 
   
5.     Dim hzDic As Object
   
6.     Dim hzArr, i&, lsArr
   
7.     Set hzDic = CreateObject("Scripting.Dictionary")
   
8.     hzArr = Sheet2.UsedRange.CurrentRegion
   
9.     For i = 2 To UBound(hzArr)
   
10.         hzDic(hzArr(i, 1) & hzArr(i, 3)) = hzDic(hzArr(i, 1) & hzArr(i, 3)) + 1
    
11.     Next
    
12.     lsArr = hzDic.keys
    
13.     Dim rng As Range
    
14.     For Each rng In Sheet1.Range("A3:A" & Sheet1.UsedRange.Rows.Count)
    
15.         For i = 0 To UBound(lsArr)
    
16.             If rng = Mid(lsArr(i), 1, 2) Then
    
17.                 Select Case Mid(lsArr(i), 3, 1)
    
18.                     Case "男"
    
19.                         rng.Offset(0, 1) = hzDic(lsArr(i))
    
20.                     Case "女"
    
21.                         rng.Offset(0, 2) = hzDic(lsArr(i))
    
22.                 End Select
    
23.             End If
    
24.         Next
    
25.     Next
    
26.    
    
27. End Sub

复制代码

vba789

NadrsSaber 发表于 2020-2-6 23:26

rng = Mid(lsArr(i), 1, 2)字符串长度不确定时，怎么提取性别，如白沙一组男，三家村女

NadrsSaber

vba789 发表于 2020-2-9 10:06
rng = Mid(lsArr(i), 1, 2)字符串长度不确定时，怎么提取性别，如白沙一组男，三家村女

Mid(lsArr(i), 3, 1)
改成
Mid(lsArr(i),len(lsArr(i),1)

ω逆鳞々

支持字典用法