分别统计A列分别有多少汉字、数字、符号

chuchenglai

如图，如题。需要统计A列分别有多少汉字、数字/字母、符号，填入C列对应的格子中去。
其中节点字符全部都不计算在内，如<A>张三</A>，只算两个汉字；<B\>等不计算。
<id>节点中间的部分不计算在内，如<id>{*********************}</id>全部不计算。

先谢过各路神仙。

Chip_Kenny

1. Sub ZZ()
   
2. Dim rp As Object, s$, n&, RXP As Object, b()
   
3. Set rp = CreateObject("vbscript.regexp")
   
4. Set RXP = CreateObject("vbscript.regexp")
   
5. ar = Range("a1:a" & [a65536].End(3).Row).Value
   
6. ReDim b(1 To UBound(ar), 1 To 3)
   
7. rp.Pattern = "[\u4e00-\u9fa5]+"
   
8. rp.Global = True
   
9. RXP.Pattern = "[0-9a-zA-Z]+"
   
10. RXP.Global = True
    
11.     For i = 1 To UBound(ar)
    
12.         s = ar(i, 1): n = Len(s)
    
13.         s = rp.Replace(s, ""): b(i, 1) = n - Len(s): n = Len(s)
    
14.         s = RXP.Replace(s, ""): b(i, 2) = n - Len(s): b(i, 3) = Len(s)
    
15.     Next
    
16. [c1].Resize(i - 1, 3) = b
    
17. End Sub

复制代码

chuchenglai

Chip_Kenny 发表于 2018-6-14 10:58

谢谢。我看了下，C列统计的是汉字，D列是数字+字母，E列是字符，大体上也能满足要求了。但是能不能把D列改成仅数字

Chip_Kenny

1. Sub ZZ()
   
2. Dim rp As Object, s$, n&, RXP As Object, b()
   
3. Dim xn As Object
   
4. Set rp = CreateObject("vbscript.regexp")
   
5. Set RXP = CreateObject("vbscript.regexp")
   
6. Set xn = CreateObject("vbscript.regexp")
   
7. ar = Range("a1:a" & [a65536].End(3).Row).Value
   
8. ReDim b(1 To UBound(ar), 1 To 3)
   
9. rp.Pattern = "[\u4e00-\u9fa5]+"
   
10. rp.Global = True
    
11. RXP.Pattern = "[0-9a-zA-Z]+"
    
12. RXP.Global = True
    
13. xn.Pattern = "\D+"
    
14. xn.Global = True
    
15.     For i = 1 To UBound(ar)
    
16.         s = ar(i, 1): n = Len(s)
    
17.         s = rp.Replace(s, ""): b(i, 1) = n - Len(s): n = Len(s)
    
18.         b(i, 2) = Len(xn.Replace(s, ""))
    
19.         b(i, 3) = Len(RXP.Replace(s, ""))
    
20.     Next
    
21. [c1].Resize(i - 1, 3) = b
    
22. End Sub

复制代码

ggmmlol

统计各类字符数量.rar (12.48 KB, 下载次数: 8)

2018-6-14 14:52 上传

点击文件名下载附件

ggmmlol

看了一下一楼的要求，还要 排除节点字符，排除id节点中间内容，所以再添加几句代码。

统计各类字符数量.rar (12.47 KB, 下载次数: 7)

2018-6-14 15:14 上传

点击文件名下载附件

ggmmlol

发重了。。。。。。。。

chuchenglai

ggmmlol 发表于 2018-6-14 15:14
看了一下一楼的要求，还要 排除节点字符，排除id节点中间内容，所以再添加几句代码。

能不能再完善下，<>里面的符号和字母都不算。如<A>张三</A>，只算两个汉字，0符号，0字母。

chuchenglai

ggmmlol 发表于 2018-6-14 15:14
看了一下一楼的要求，还要 排除节点字符，排除id节点中间内容，所以再添加几句代码。

而且我测试了一下，<id>节点里面好像还是算进去了。我希望id节点里面所有的不管市汉字、符号、数字，都不计入总数

lsdongjh

1. Option Explicit
   
2. 
   
3. Sub Test()
   
4.     Dim lngRows As Long
   
5.     Dim arr As Variant, strTemp As String
   
6.    
   
7.     lngRows = Sheet1.Range("A" & Rows.Count).End(xlUp).Row
   
8.     arr = Sheet1.Range("A1:A" & lngRows)
   
9.    
   
10.     '不知道为什么数组参数的Index在你的XLS中无效，只能循环拼装所有的单元格了
    
11.     'arr = Application.WorksheetFunction.Index(arr, 0, 1)
    
12.    
    
13.     For lngRows = LBound(arr) To UBound(arr)
    
14.         strTemp = strTemp & arr(lngRows, 1)
    
15.     Next
    
16.    
    
17.     arr = CountChar(strTemp)
    
18.    
    
19.     Sheet1.Range("C1").Resize(3, 1) = arr
    
20. End Sub
    
21. 
    
22. 
    
23. Function CountChar(strVal As String) As Variant
    
24.     Dim objReg As Object
    
25.     Dim strTemp As String, lngCount As Long
    
26.     Dim objMatchs As Object
    
27.     Dim arrResult(1 To 3, 1 To 1) As Variant '返回结果
    
28. 
    
29.     Set objReg = CreateObject("VBScript.RegExp")
    
30.     objReg.Global = True
    
31.    
    
32.     '替换掉所有的空格和 标签
    
33.     objReg.Pattern = "<.*?>|{.*?}|[\s\t\n]"
    
34.     strTemp = objReg.Replace(strVal, "")
    
35. 
    
36.     lngCount = Len(strTemp) '字符总数
    
37.    
    
38.     '汉字字符数量
    
39.     objReg.Pattern = "[\u4e00-\u9fa5]"
    
40.     Set objMatchs = objReg.Execute(strTemp)
    
41.     arrResult(1, 1) = objMatchs.Count
    
42.    
    
43.     '数字/字母数量
    
44.     objReg.Pattern = "[0-9a-zA-Z]"
    
45.     Set objMatchs = objReg.Execute(strTemp)
    
46.     arrResult(2, 1) = objMatchs.Count
    
47.    
    
48.     '其他字符数量
    
49.     arrResult(3, 1) = lngCount - arrResult(1, 1) - arrResult(2, 1)
    
50.    
    
51.     CountChar = arrResult
    
52.    
    
53.     Set objMatchs = Nothing
    
54.     Set objReg = Nothing
    
55. End Function
    

复制代码