我对这种排序毫无经验求解论坛的大神们，感激不尽！

chenbiao2012

Sub test()
    Set d = CreateObject("scripting.dictionary")
    a = Array("户主", "父亲", "母亲", "夫", "妻", "兄", "弟", "姐姐", "妹妹", "儿媳")
    For i = 0 To UBound(a)
        d(a(i)) = i * 10 ^ (-9)
    Next
    With Sheets("sheet1")
        r = .Cells(Rows.Count, 1).End(3).Row
        arr = .Range("a1:g" & r)
        For i = 2 To UBound(arr)
            If Not d.exists(arr(i, 5)) Then
                n = n + 1
                d(arr(i, 5)) = n
            End If
            If InStr(arr(i, 6), "子") Or InStr(arr(i, 6), "女") Then
                s = Mid(arr(i, 3), 7, 8) * 10 ^ (-8)
            Else
                If d.exists(arr(i, 6)) Then
                    s = d(arr(i, 6))
                End If
            End If
            arr(i, 7) = d(arr(i, 5)) + s
        Next
        .[a1].Resize(UBound(arr), 7) = arr
        .[a1].Resize(r, 8).Sort key1:=Range("g1"), order1:=1, Header:=1
        .Range("g:g").Delete
    End With
End Sub[/code]
重名的问题不好解决，再就是一家有三个女儿，那应该是按岁数排序的吧

chenbiao2012

1. Sub test()
   
2.     Set d = CreateObject("scripting.dictionary")
   
3.     a = Array("户主", "父亲", "母亲", "夫", "妻", "兄", "弟", "姐姐", "妹妹", "儿媳")
   
4.     For i = 0 To UBound(a)
   
5.         d(a(i)) = i * 10 ^ (-9)
   
6.     Next
   
7.     With Sheets("sheet1")
   
8.         r = .Cells(Rows.Count, 1).End(3).Row
   
9.         arr = .Range("a1:g" & r)
   
10.         For i = 2 To UBound(arr)
    
11.             If Not d.exists(arr(i, 5)) Then
    
12.                 n = n + 1
    
13.                 d(arr(i, 5)) = n
    
14.             End If
    
15.             If InStr(arr(i, 6), "子") Or InStr(arr(i, 6), "女") Then
    
16.                 s = Mid(arr(i, 3), 7, 8) * 10 ^ (-8)
    
17.             Else
    
18.                 If d.exists(arr(i, 6)) Then
    
19.                     s = d(arr(i, 6))
    
20.                 End If
    
21.             End If
    
22.             arr(i, 7) = d(arr(i, 5)) + s
    
23.         Next
    
24.     End With
    
25.     With Sheets("sheet2")
    
26.         .UsedRange.ClearContents
    
27.         .[a1].Resize(UBound(arr), 7) = arr
    
28.         .[a1].Resize(r, 8).Sort key1:=.Range("g1"), order1:=1, Header:=1
    
29.         .Range("g:g").Delete
    
30.     End With
    
31. End Sub

复制代码

这个是在表2中进行排序的，但是遇到重名时需要再进一步判断

yjh_27

WONIUWANG 发表于 2015-12-14 18:43
我将这个附件传了上来了 有些内容保密就修改了

假设同一户已连续在一起，相邻户户主不重名即可

附件更新，做了二个按钮，分别升、降序

WONIUWANG

chenbiao2012 发表于 2015-12-14 21:44
Sub test()
    Set d = CreateObject("scripting.dictionary")
    a = Array("户主", "父亲", "母亲",  ...

d ＝1*10∧(-9)这是什么意思   大神能否给我讲讲思路

WONIUWANG

yjh_27 发表于 2015-12-14 22:54
假设同一户已连续在一起，相邻户户主不重名即可

我的天 大神 这个这么多代码啊。大神有心了 感动死了。但是我点了命令按钮好像不行啊。。

yjh_27

WONIUWANG 发表于 2015-12-15 09:17
我的天 大神 这个这么多代码啊。大神有心了 感动死了。但是我点了命令按钮好像不行啊。。

已更新附件

只有模块1是新写的，其他是通用的。

beanchan

t13564865256 发表于 2015-12-14 17:41
1做为主关键字-普通排序，2作为负关键字-自定义序列排序

个人意见，3楼给出了解题思路。无意冒犯后面用VBA解决问题的楼友，用VBA是：杀鸡用牛刀。

绝帝苍狼

看了那么多大师，我就来个最笨点吧。不过要把户主和排序一起选然后排序。

yjh_27

beanchan 发表于 2015-12-15 14:18
个人意见，3楼给出了解题思路。无意冒犯后面用VBA解决问题的楼友，用VBA是：杀鸡用牛刀。

如有重名户主，将造成混淆

mjjsum

先在自定义序列中添加 户主。妻，兄弟，姐姐，妹妹，子，孙 这个排序序列，然后在表中再排序即可