[已解决]再次求助：VBA＿鼠标选取当前列自定义排序-求修改代码

爱疯

1. Sub 科室排序()
   
2.     Dim arr, i&, c, r0, r1
   
3.     '设置自定义排序的顺序
   
4.     arr = Array("外妇科", "手术室", "内儿科", "西医科", "中医科", "耳鼻喉科", "放射科", "检验科", "B超室", "口腔科", "针灸科", "西药房", "中药房", "收费室", "疾控科", "合管办", "后勤科")
   
5.     With Application
   
6.         .ScreenUpdating = False
   
7.         .AddCustomList ListArray:=arr
   
8.         i = .GetCustomListNum(arr)    '返回字符串数组的自定义序列号
   
9.         '设置排序的操作区域
   
10.         c = Range("A1").End(xlToRight).Column
    
11.         r0 = ActiveCell.Row
    
12.         r1 = ActiveCell.End(xlDown).Row
    
13.         With Range(Cells(r0, 1), Cells(r1, c))
    
14.             '设置排序的起始单元格
    
15.             .Sort key1:=ActiveCell, order1:=xlAscending, _
    
16.                   Header:=xlNo, OrderCustom:=i + 1
    
17.         End With
    
18.         .DeleteCustomList ListNum:=i
    
19.         .ScreenUpdating = True
    
20.         MsgBox "排序完成", vbInformation
    
21.     End With
    
22. End Sub

复制代码

附件2.rar (21.81 KB, 下载次数: 9)

2012-2-6 21:45 上传

点击文件名下载附件
又修改了1下，不知是不是这样

happym8888

1. Public Sub PAIXU()
   
2. Dim arr, i&
   
3. arr = Array("外妇科", "手术室", "内儿科", "西医科", "中医科", "耳鼻喉科", "放射科", "检验科", "B超室", "口腔科", "针灸科", "西药房", "中药房", "收费室", "疾控科", "合管办", "后勤科")
   
4. With Application
   
5. .ScreenUpdating = False
   
6. .AddCustomList ListArray:=arr
   
7. i = .GetCustomListNum(arr)
   
8. x = Selection.Column
   
9. With Range("B" & ActiveCell.Row & ":N" & Range("A65536").End(xlUp).Row)
   
10. .Sort Key1:=Columns(x), Order1:=xlAscending, Header:=xlNo, OrderCustom:=i + 1, SortMethod:=xlPinYin, DataOption1:=xlSortNormal
    
11. End With
    
12. .DeleteCustomList ListNum:=i
    
13. .ScreenUpdating = True
    
14. MsgBox "排序完成", vbInformation
    
15. End With
    
16. End Sub
    

复制代码

楼主同志，请问你有没有试过我的代码？
附件（C17）.rar (25.38 KB, 下载次数: 11)

2012-2-6 21:45 上传

点击文件名下载附件

yjwdjfqb

sunjing-zxl 发表于 2012-2-6 21:41
早点说出你表格变动状态早解决了，用这个吧

老师你的代码会删除表格中的数据，

假如，假如我在科室中添加一个“收发室”这个科室的话，进行排序会删除收发室这个科室的行

sunjing-zxl

那你要说清楚，你的数组表格有些科室不参与排序。
这个好办，稍等

happym8888

yjwdjfqb 发表于 2012-2-6 21:30
老师你好，我试了，可能是我表述的不清楚，我目的是，工作表改变时，不改变代码，也能正确排序。

排序 ...

如果是你表述得不清楚，你应该在原帖继续表达清楚，不应该到这边重新发帖。最重要的是你没有说明你要点哪一列就按这列作为主要关键字排序，估计和你不知道那个Sort Key1是什么意思有关。

happym8888

你知道你现在麻烦多少人在帮你解决问题吗？

yjwdjfqb

爱疯 发表于 2012-2-6 21:45
又修改了1下，不知是不是这样

谢谢老师，就是这样，但有一个小问题老师

排序的顺序　　　（自定义的排序顺序－其它内容－空白单元格）

还有这个地方        c = Range("A1").End(xlToRight).Column
A1是什么意思。

请老师再修改下

yjwdjfqb

happym8888 发表于 2012-2-6 21:55
你知道你现在麻烦多少人在帮你解决问题吗？

麻烦各位老师了，21楼的差不多是我想要的了，

sunjing-zxl

再试试

1. Sub 排序()
   
2.     Dim arr1, arr2, arr3
   
3.     Dim i As Long, j As Long, k As Long, n As Long, m As Long
   
4.     Dim Co As Long, Ro As Long
   
5.     '设置自定义排序的顺序
   
6.     arr1 = Array("外妇科", "手术室", "内儿科", "西医科", "中医科", "耳鼻喉科", "放射科", "检验科", "B超室", "口腔科", "针灸科", "西药房", "中药房", "收费室", "疾控科", "合管办", "后勤科")
   
7.     arr2 = Range("A1:N1")
   
8.     For i = 1 To UBound(arr2, 2)
   
9.         If arr2(1, i) = "科室" Then
   
10.             Co = i
    
11.             Exit For
    
12.         End If
    
13.     Next i
    
14.     n = ActiveCell.Row    '获取活动单元格行号
    
15.     m = [A65536].End(xlUp).Row
    
16.     If n = 1 Or n > m Then
    
17.         MsgBox "活动行超出范围,不能排序"
    
18.         Exit Sub
    
19.     End If
    
20.     arr2 = Range(Cells(n, 1), Cells(m, "N"))    '活动单元格至最后一行数据赋值给数组arr2
    
21.     ReDim arr3(1 To UBound(arr2), 1 To UBound(arr2, 2))
    
22.     m = 0    '计数变量
    
23.     For i = 0 To UBound(arr1)
    
24.         For j = 1 To UBound(arr2)
    
25.             If arr1(i) = arr2(j, Co) Then
    
26.                 m = m + 1
    
27.                 For k = 1 To UBound(arr2, 2)
    
28.                     arr3(m, k) = arr2(j, k)
    
29.                 Next k
    
30.             End If
    
31.         Next j
    
32.     Next i
    
33.     Ro = UBound(arr2) + 1
    
34.     If m < UBound(arr2) Then
    
35.         For i = 1 To UBound(arr2)
    
36.             m = 0
    
37.             For j = 0 To UBound(arr1)
    
38.                 If arr1(j) = arr2(i, Co) Then
    
39.                     m = 1
    
40.                     Exit For
    
41.                 End If
    
42.             Next j
    
43.             If m = 0 Then
    
44.                 Ro = Ro - 1
    
45.                 For k = 1 To UBound(arr2, 2)
    
46.                     arr3(Ro, k) = arr2(i, k)
    
47.                 Next k
    
48.             End If
    
49.         Next i
    
50.     End If
    
51.     Cells(n, 1).Resize(UBound(arr3), UBound(arr3, 2)) = arr3
    
52.     MsgBox "排序完成"
    
53. End Sub

复制代码

yjwdjfqb

爱疯 发表于 2012-2-6 21:45
又修改了1下，不知是不是这样

老师你好，你刚发的那个代码，已经是我想要的了，

就是不能进行正确的排序。
排序的顺序按以下顺序
（自定义排序的顺序---其它内容----空白单元格）