地址门牌号加房号排序，希望可以帮助有需要的朋友（不是本人作品）

黄金万两︶ㄣ

黄金万两︶ㄣ 发表于 2014-2-2 14:18
我附件是B列中在文字发生多种变化都可以排序。只是差一点不完美，总比一般排序好多了，因为一般排序的话，出 ...

嗯，好的。已更新附件。

zhaogang1960

1. Sub Macro1()
   
2.     Dim matchs As Object, arr, brr(), i&, s$
   
3.     arr = Range("b2:b" & Range("b" & Rows.Count).End(xlUp).Row)
   
4.     ReDim brr(1 To UBound(arr), 1 To 1)
   
5.     With CreateObject("VBScript.RegExp")
   
6.         .Global = True
   
7.         .Pattern = "[0-9]+"
   
8.         For i = 1 To UBound(arr)
   
9.             Set matchs = .Execute(arr(i, 1))
   
10.             s = matchs(0).Value
    
11.             brr(i, 1) = Format(Val(s), "0000") & Replace(arr(i, 1), s, "")
    
12.         Next
    
13.     End With
    
14.     [d2].Resize(i - 1) = brr
    
15.     With [d2].Resize(i - 1)
    
16.         .Value = brr
    
17.         Range("A2:D" & i).Sort Key1:=Range("D2"), Order1:=xlAscending, Key2:=Range("C2"), Order2:=xlAscending, Header:=xlNo
    
18.         .Clear
    
19.     End With
    
20. End Sub
    

复制代码

zhaogang1960

请测试附件
将某列变换再排序.rar (22.32 KB, 下载次数: 27)

2014-2-2 16:02 上传

点击文件名下载附件

jzhhua

还是将门牌号设置在F列之后，G列为空白，这样F列之前的都能一起扩展按F列排序。经过再修改的加载宏！

黄金万两︶ㄣ

jzhhua 发表于 2014-7-26 12:35
还是将门牌号设置在F列之后，G列为空白，这样F列之前的都能一起扩展按F列排序。经过再修改的加载宏！

朋友，发代码到论坛。。。

云雾贡茶18

Sub 门号排序()
    Dim matchs As Object, arr, brr&(), i&
    arr = Range("F2:F" & Range("F" & Rows.Count).End(xlUp).Row)
    ReDim brr(1 To UBound(arr), 1 To 1)
    With CreateObject("VBScript.RegExp")
        .Global = True
        .Pattern = "[0-9]+"
        For i = 1 To UBound(arr)
            Set matchs = .Execute(arr(i, 1))
            If .test(arr(i, 1)) Then brr(i, 1) = matchs(0).Value
        Next
    End With
    [G2].Resize(i - 1) = brr
    Range("A2:G" & i).Sort Key1:=Range("G2"), Order1:=xlAscending, Header:=xlNo
    [G:G].Clear
End Sub
   
' 备注：1、门牌号必须调整在F列中F2单元格以下；G列为空白(辅助替换列）。
'
'扩展排序区域为（A2：F65536 ）！！！

云雾贡茶18

1. Sub 门号排序()
   
2.     Dim matchs As Object, arr, brr&(), i&
   
3.     arr = Range("F2:F" & Range("F" & Rows.Count).End(xlUp).Row)
   
4.     ReDim brr(1 To UBound(arr), 1 To 1)
   
5.     With CreateObject("VBScript.RegExp")
   
6.         .Global = True
   
7.         .Pattern = "[0-9]+"
   
8.         For i = 1 To UBound(arr)
   
9.             Set matchs = .Execute(arr(i, 1))
   
10.             If .test(arr(i, 1)) Then brr(i, 1) = matchs(0).Value
    
11.         Next
    
12.     End With
    
13.     [G2].Resize(i - 1) = brr
    
14.     Range("A2:G" & i).Sort Key1:=Range("G2"), Order1:=xlAscending, Header:=xlNo
    
15.     [G:G].Clear
    
16. End Sub
    
17.    
    
18. ' 备注：1、门牌号必须调整在F列中F2单元格以下；G列为空白(辅助替换列）。
    
19. '
    
20. '扩展排序区域为（A2：F65536 ）！！！

复制代码

黄金万两︶ㄣ

云雾贡茶18 发表于 2014-9-13 14:05

我测试过你的代码，没有变动。。。

云雾贡茶18

1. 在F列之后插入两列：
   
2. G2填入门牌号正号_取号公式：
   
3. =IF(ISERROR(FIND("-",F2)),MID(F2,LENB(F2)-LEN(F2),LEN(F2)*2-LENB(F2)),MID(LEFT(F2,FIND("-",F2)),LENB(LEFT(F2,FIND("-",F2)))-LEN(LEFT(F2,FIND("-",F2)))+1,LEN(LEFT(F2,FIND("-",F2)))*2-LENB(LEFT(F2,FIND("-",F2)))-1))
   
4. H2填入门牌号附号_取号公式：
   
5. =IF(ISERROR(FIND("-",F2)),"",MID(F2,FIND("-",F2)+1,LEN(F2)-1-FIND("-",F2)))
   
6. 分享交流，重在引玉！

复制代码

黄金万两︶ㄣ

云雾贡茶18 发表于 2014-9-14 13:50

看不懂，本人跳过函数学习，只会vba