[求助]按姓名笔画排序？

hzynew

现在这个宏要对该区域(比如A1:A8)选择2次。

如何才能做到用鼠标选择一次某区域，对所选区域进行排序，然后按原来的分布把排序结果写回去？

 

v9deUC1z.rar (7.66 KB, 下载次数: 90)

2008-2-2 14:25 上传

点击文件名下载附件
[求助]按姓名笔画排序？

[此贴子已经被作者于2008-2-2 14:25:28编辑过]

northwolves

如何才能做到用鼠标选择一次某区域，对所选区域进行排序，然后按原来的分布把排序结果写回去？

----------------------------------

好难懂.

hzynew

QUOTE:

以下是引用northwolves在2008-2-2 16:58:05的发言：

好难懂.

OK，做到了，就是如下附件的意思！ 不知道还有什么更好的方法？

btw：有点不明白，为什么“区”会排在“王”的前面？

 

utzunmhp.rar (10.4 KB, 下载次数: 66)

2008-2-2 20:29 上传

点击文件名下载附件
[求助]按姓名笔画排序？

[此贴子已经被作者于2008-2-2 20:33:42编辑过]

山菊花

供参考。

hzynew

非常感谢！慢慢学习。

jiangmen

感谢！

[此贴子已经被作者于2008-3-4 20:31:52编辑过]

jiangmen

为什么我的文件只能点击菜单下的宏才能执行？请教！

z75ETA6e.rar (66.04 KB, 下载次数: 53)

2008-2-8 09:38 上传

点击文件名下载附件
[求助]按姓名笔画排序？

ifhwfu

QUOTE:

以下是引用山菊花在2008-2-4 18:49:44的发言：

Public ds
Sub 整理()
    On Error Resume Next
    Dim ary(), arr As Range, c As Range, c2 As Range, cAddress$
    Application.EnableEvents = False
   
    If TypeName(ds) = "Empty" Then
        Dim nRow%, m%
       
        Set ds = CreateObject("scripting.dictionary") '定义字典
        nRow = Sheets("笔画库").[a65536].End(xlUp).Row
        hanzi = Sheets("笔画库").Range("a1:a" & nRow)
       
        For i = 1 To nRow '把汉字添加到字典中
            ds.Add hanzi(i, 1), m + 1
            If Err.Number = 0 Then
                m = m + 1
            End If
            Err.Clear
        Next
    End If
   
   
    cAddress = Selection.Address
    Set arr = Application.InputBox(Prompt:="说明：" & vbCrLf & vbNewLine & "所选区域将依照姓名笔划顺序按原布局重新调整。", Title:="选择要排序的区域 ... ...", Type:=8, Default:=cAddress)
   
    Application.ScreenUpdating = False
   
    If arr Is Nothing Then: Exit Sub
   
    p = Application.WorksheetFunction.CountA(arr)
   
    ReDim ary(1 To p, 1 To 2)
   
    For Each c2 In arr
        If c2 <> "" Then
            k = k + 1
            ary(k, 1) = c2
           
            For m = 1 To Len(c2)
                If m > 4 Or Mid(c2, m, 1) = "(" Then Exit For
                ary(k, 2) = ary(k, 2) + ds(Mid(c2, m, 1)) * 10000 ^ (4 - m)
            Next
           
        End If
    Next
   
    Range("iu1:iv" & p) = ary
   
    Columns("IU:IV").Sort Key1:=Range("IV1"), Order1:=xlAscending, Header:=xlGuess, _
            OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod _
            :=xlStroke, DataOption1:=xlSortNormal
    k = 0
    For i = 1 To arr.Rows.Count
        For j = 1 To arr.Columns.Count
            If arr(i, j) <> "" Then: k = k + 1: arr(i, j) = Range("iu" & k)
        Next j
    Next i
   
    Range("iu1:iv" & k).ClearContents
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

学习了，很多方面知识的综合运用阿！

jiangmen

以上代码加到了我的附件上，用按钮运行依然还是得不到正确结果，在工具菜单中选择宏来运行则可以。

很想知道原因。

hzynew

山菊花超版，能不能再修改一下：让表格中的“单字”名 与 “Bhpm自定义函数”一样——姓名之间不论有没有空格都排在前面（如：“王二” 与 “王  二”一样都排在“王一二”前面）。

[此贴子已经被作者于2008-2-10 16:09:01编辑过]