公式能解决的，代码有什么好的方法？

dsmch · 发表于 2014-12-6 09:55

在函数版看到一问题
http://www.excelpx.com/thread-335629-1-1.html

尝试用代码解决一下，考虑用字典，还要借助辅助单元格两次排序，然后连接字符串
感觉比较麻烦，请大家讨论一下，用代码有什么好的办法？

dsmch · 发表于 2014-12-6 16:31

写一段代码抛砖引玉，不相信公式能够解决的，代码会如此繁复
Sub Macro1()
Dim arr, d, i&, j%, zf$, z$
Set d = CreateObject("scripting.dictionary")
arr = Range("a1").CurrentRegion
For i = 2 To UBound(arr)
zf = arr(i, 1)
For j = 1 To Len(zf)
z = Mid(zf, j, 1)
d(z) = d(z) + 1
Next
Range("e1").Resize(1, d.Count) = d.keys
Range("e2").Resize(1, d.Count) = d.items
Range("e1").CurrentRegion.Sort Key1:=[e2], Order1:=xlDescending, Key2:=[e1], _
Order2:=xlAscending, Header:=xlGuess, Orientation:=xlLeftToRight
w = Range("e1").Resize(1, d.Count)
arr(i, 2) = Join(Application.Index(w, 1, 0), "")
Range("e1").CurrentRegion = ""
d.RemoveAll
Next
Range("b1").Resize(UBound(arr)) = Application.Index(arr, 0, 2)
End Sub

dsmch · 发表于 2014-12-6 19:33

不借助单元格排序，有没有简单的方法可以实现要求？

dsmch · 发表于 2015-2-26 08:33

Sub Macro1()
Dim arr, d, i&, j%, k%
Set d = CreateObject("scripting.dictionary")
arr = [a2:a5]
For i = 1 To UBound(arr)
zf = arr(i, 1)
For j = 1 To Len(zf)
z = Val(Mid(zf, j, 1))
d(z) = d(z) + 1
Next
zd = Application.Max(d.items)
zx = Application.Min(d.items)
p = ""
For j = zd To zx Step -1
For k = 0 To 9
If d(k) = j Then p = p & k
Next
Next
MsgBox p
arr(i, 1) = p
d.RemoveAll
Next
Range("e2").Resize(UBound(arr)) = arr
End Sub

复制代码

grf1973 · 发表于 2015-2-26 10:20

借用4楼思路，不用字典：

Sub Macro1()
Dim arr, i&, j%, k%
arr = [a2:a5]
For i = 1 To UBound(arr)
zf = arr(i, 1)
For j = Len(zf) To 1 Step -1
For k = 0 To 9
If Len(zf) - Len(Replace(zf, k, "")) = j Then p = p & k
Next
Next
arr(i, 1) = p: p = ""
Next
Range("e2").Resize(UBound(arr)) = arr
End Sub

复制代码

dsmch · 发表于 2015-2-26 11:12

Sub Macro1()
Dim arr, w(9), i&, j%, k%
arr = [a2:a5]
For i = 1 To UBound(arr)
zf = arr(i, 1)
For j = 1 To Len(zf)
z = Val(Mid(zf, j, 1))
w(z) = w(z) + 1
Next
p = ""
For j = Len(zf) To 1 Step -1
For k = 0 To 9
If w(k) = j Then p = p & k
Next
Next
arr(i, 1) = p
Erase w
Next
Range("e2").Resize(UBound(arr)) = arr
End Sub

复制代码

香川群子 · 发表于 2015-2-26 13:54

点评：

一、在本楼题目这样纯数字计算时，2楼、4楼使用字典的代码就没有意义了。

二、5楼算法有重大意义，但反复使用Replace处理效率非常低。

三、6楼代码使用数组记录大大改进了计算效率。
但尚有改进余地……最后的提取结果有很大的冗余计算量，需要计算字符长度*10（遍历0-9）

四、代码改进如下：

Sub test5()
Dim arr, a&(9), i&, j&, k&, n&, s$, t$
arr = Range("a1").CurrentRegion
For i = 2 To UBound(arr)
s = arr(i, 1)
n = Len(s)
For j = 1 To n
t = Mid(s, j, 1)
a(t) = a(t) + 1
Next
s = ""
k = 0
Do
k = k + 1
For j = 9 To 0 Step -1
If a(j) = k Then s = j & s: n = n - a(j): If n = 0 Then Exit Do
Next
Loop
arr(i, 1) = "'" & s '此处需加单引号、保证首位0能被显示。
Erase a
Next
Range("d1").Resize(UBound(arr)) = arr
End Sub

复制代码

但实际上，此代码和6楼代码比速度的差异也很有限。……呵呵，只能说是一种可以借鉴的思路。
或许在别处的类似问题的处理上，速度的差异就会有意义了。

pengyx · 发表于 2016-9-1 23:54

本帖最后由 pengyx 于 2016-9-2 14:07 编辑

试写一个：每个字符串整理只需看字符串长度*2+10次即可
Sub test6()
Dim arr, w(9),  i&, j%, k%
arr = [a2:a5]
For i = 1 To UBound(arr)
zf = arr(i, 1)
Redim x(1 to Len(zf))
   t = ""
For j = 1 To Len(zf)
      z = Val(Mid(zf, j, 1))
      w(z) = w(z) + 1
Next
For k = 1 To 10
      If w(k - 1) <> "" Then
         a = w(k - 1)
         x(a) = x(a) & k - 1
      End If
Next
For l = Len(zf) To 1 Step -1
      If x(l) <> "" Then
         t = t & x(l)
      End If
Next
arr(i, 1) = "'" & t
Erase w
Next
[e2].Resize(UBound(arr)) = arr
End Sub

hrbxpj · 发表于 2017-6-2 15:35

OK各位大师谢谢啦

		自动登录	找回密码
密码			注册

公式能解决的，代码有什么好的方法？

评分

评分

评分