单元格内数据是逗号隔开的，宏如何实现给单元格内数据由小到大排序

Zamyi · 发表于 2015-4-23 17:07

适合二楼

复制代码

jsxjd · 发表于 2015-4-23 17:21

另一种方法：

Private Sub CommandButton1_Click()
[B:B].ClearContents
For Each c In Range([A1], Cells(Rows.Count, 1).End(xlUp))
s = Trim(c.Value)
If Len(s) > 0 Then
x = Split(s, ",")
If UBound(x) = LBound(x) Then
c.Offset(, 1) = s
Else
n = 1: For i = 1 To 9
If (Asc(Mid(s, i, 1)) < 48) Or (Asc(Mid(s, i, 1)) > 57) Then n = n + 1 Else Exit For
Next
k = 0: For i = LBound(x) To UBound(x): k = k + 1
ss = Replace("small({" & Replace(s, Left(s, n - 1), "") & "},KKK)", "KKK", k)
x(i) = Left(s, n - 1) & Evaluate(ss)
Next
c.Offset(, 1) = Join(x, ",")
End If
End If
Next
End Sub

复制代码

jsxjd · 发表于 2015-4-23 17:22

jsxjd 发表于 2015-4-23 16:48

头标识需要识别！

arcticstar · 发表于 2015-5-16 10:46

以上代码在1个字母情况下没问题，但数据中存在多个字母时就出现问题：
比如单元格中数据为：RE,LN,RA，就出现无法排序的问题。请问如何解决？

bluexuemei · 发表于 2015-5-16 11:05

Sub test()
'需要安装ACTIVERUBY ，下载地址 http://www.artonx.org/data/asr/Ruby-2.1.1.msi
Set ojs = CreateObject("scriptcontrol"): ojs.Language = "rubyscript"
ojs.eval ("def aa(aa) $aa=aa.flatten.compact end")
y = ojs.Run("aa", Range("A1", [a65536].End(3)).Value)
y = ojs.eval("$aa.map{|s|s.split(',').sort_by{|i|i.gsub(/\d+/) {|s| '%08d' % s.to_i }}.join(',')}.zip")
[b1].Resize(UBound(y) + 1) = y
'Stop
End Sub

复制代码

好奇心 · 发表于 2015-5-17 15:44

arcticstar 发表于 2015-5-16 10:46
以上代码在1个字母情况下没问题，但数据中存在多个字母时就出现问题：
比如单元格中数据为：RE,LN,RA，就 ...

Private Sub Cmm()
[B:B].ClearContents
Dim a(), b()
Set d = CreateObject("scripting.dictionary")
For Each c In Range([A1], Cells(Rows.Count, 1).End(xlUp))
s = Trim(c.Value)
If Len(s) > 0 Then
x = Split(s, ",")
If UBound(x) = LBound(x) Then
c.Offset(, 1) = s
Else
n = 0
For j = LBound(x) To UBound(x)
For i = 1 To Len(x(j))
If (Asc(Mid(x(j), i, 1)) < 48) Or (Asc(Mid(x(j), i, 1)) > 57) Then n = n + 1 Else Exit For
Next
ReDim Preserve a(0 To j)
ReDim Preserve b(0 To j)
a(j) = Mid(x(j), 1, n)
b(j) = CInt(Mid(x(j), n + 1))
d(b(j)) = a(j)
n = 0
Next
For ii = 0 To UBound(x)
For jj = ii + 1 To UBound(x)
If b(ii) > b(jj) Then
TEMP = b(jj)
b(jj) = b(ii)
b(ii) = TEMP
End If
Next
Next
TEMP = ""
s = ""
kk = kk + 1
For i = LBound(b) To UBound(b)
If d.Exists(b(i)) Then s = s & d(b(i)) & b(i) & ","
Next
d.RemoveAll
Erase a, b
c.Offset(, 1) = s
End If
End If
Next
End Sub

复制代码

arcticstar · 发表于 2015-5-18 15:58

好奇心发表于 2015-5-17 15:44

问题依旧，还是会报错，请测试附件

工作簿1.zip (7.23 KB, 下载次数: 21)

好奇心 · 发表于 2015-5-18 16:08

arcticstar 发表于 2015-5-18 15:58
问题依旧，还是会报错，请测试附件

本人的版本为2003，无法测试您的附件，请上
版本为2003的附件。

yjh_27 · 发表于 2015-5-18 17:33

好奇心发表于 2015-5-18 16:08
本人的版本为2003，无法测试您的附件，请上
版本为2003的附件。

用正则处理，先按字母、后按数字排序

arcticstar · 发表于 2015-5-23 13:58

好奇心发表于 2015-5-18 16:08
本人的版本为2003，无法测试您的附件，请上
版本为2003的附件。

附件为2003版，请帮解决，谢谢！

工作簿1.rar (4.26 KB, 下载次数: 16)

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