|
发表于 2017-6-19 11:25
来自手机
|
显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用 · 内置多项VBA编程加强工具 ★ 免费下载 ★ ★ 使用手册★
本帖最后由 lss001 于 2017-6-19 16:49 编辑
假如数据在第一行
从第二行开始存放结果
则代码如下:
Sub tjwb()
x = Cells(1, 1).CurrentRegion.Columns.Count
Set d = CreateObject("Scripting.Dictionary")
ar = Range(Cells(1, 1), Cells(1, x))
For i = 1 To x: t = t & ar(1, i): Next
ReDim br(1 To Len(t), 1 To 1)
For j = 1 To Len(t): br(j, 1) = Mid(t, j, 1): Next
For k = 1 To UBound(br): d(br(k, 1)) = "": Next
ReDim dr(1 To UBound(d.keys) + 1, 1 To 1)
For g = 0 To UBound(d.keys): s = 0
For h = 1 To Len(t)
If d.keys()(g) = br(h, 1) Then s = s + 1
Next
dr(g + 1, 1) = s
Next
Range("a2:b" & Len(t)) = ""
[a2].Resize(UBound(d.keys) + 1, 1) = Application.Transpose(d.keys)
[b2].Resize(UBound(dr), 1) = dr
Range("a2:b" & Len(t)).Sort Key1:=Range("b2"), Order1:=1 '1升2降
End Sub
|
|