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

yjwdjfqb

上回发的求助，可能是我表达的不清楚，所以。。朋友们做的我没有用上。。。。。

希望这回朋友们能看清我的要求，

具体请看图片　。。。谢谢大家！！！



VBA＿鼠标选取当前列自定义排序-求修改代码.rar (22.99 KB, 下载次数: 433)

2012-2-6 19:57 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

爱疯

2012-2-6 23:27

yjwdjfqb 发表于 2012-2-6 23:13
c = Range("iv1").End(xlToLeft).Column    '数据源最右侧列号

如果表头不在第一行，也有问题

1. 
   
2. Sub 科室排序()
   
3.     Dim arr, i&, c, r
   
4.     '设置自定义排序的顺序
   
5.     arr = Array("外妇科", "手术室", "内儿科", "西医科", "中医科", "耳鼻喉科", "放射科", "检验科", "B超室", "口腔科", "针灸科", "西药房", "中药房", "收费室", "疾控科", "合管办", "后勤科")
   
6.     If Not Cells.Find("序号") Is Nothing Then
   
7.         Set Rng = Cells.Find("序号").CurrentRegion
   
8.         If Not Intersect(Rng, ActiveCell) Is Nothing Then
   
9.             With Application
   
10.                 .ScreenUpdating = False
    
11.                 .AddCustomList ListArray:=arr
    
12.                 i = .GetCustomListNum(arr)    '返回字符串数组的自定义序列号
    
13.                 c = Rng.Item(1, 1).End(xlToRight).Column   '数据源最右侧列号
    
14.                 r = Cells(65536, ActiveCell.Column).End(xlUp).Row    '所选单元格所在列最后一个数据的行号
    
15.                 '排序区域
    
16.                 With Range(Cells(ActiveCell.Row, Rng.Column), Cells(r, c))
    
17.                     '设置排序的起始单元格
    
18.                     .Sort key1:=ActiveCell, order1:=xlAscending, _
    
19.                           Header:=xlNo, OrderCustom:=i + 1
    
20.                 End With
    
21.                 .DeleteCustomList ListNum:=i
    
22.                 .ScreenUpdating = True
    
23.                 MsgBox "排序完成", vbInformation
    
24.             End With
    
25.         End If
    
26.     End If
    
27. End Sub

复制代码

(, 下载次数: 11)

上传

点击文件名下载附件

跳转到最佳答案楼层

爱疯

从图中代码看，目的是：
1）添加一个自定义序列
2）应用在某一区域
3）在该区按自定义序列排序

不知哪一步开始，不合楼主要求（楼主是希望怎样）。
一步步说明，相信很多高手能帮上忙的

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.     '设置自定义排序的顺序
   
5.     arr1 = Array("外妇科", "手术室", "内儿科", "西医科", "中医科", "耳鼻喉科", "放射科", "检验科", "B超室", "口腔科", "针灸科", "西药房", "中药房", "收费室", "疾控科", "合管办", "后勤科")
   
6. 
   
7.     n = ActiveCell.Row    '获取活动单元格行号
   
8.     arr2 = Range(Cells(n, 1), Cells([A65536].End(xlUp).Row, "N"))    '活动单元格至最后一行数据赋值给数组arr1
   
9.     ReDim arr3(1 To UBound(arr2), 1 To UBound(arr2, 2))
   
10.     m = 0    '计数变量
    
11.     For i = 0 To UBound(arr1)
    
12.         For j = 1 To UBound(arr2)
    
13.             If arr1(i) = arr2(j, 3) Then
    
14.                 m = m + 1
    
15.                 For k = 1 To UBound(arr2, 2)
    
16.                     arr3(m, k) = arr2(j, k)
    
17.                 Next k
    
18.             End If
    
19.         Next j
    
20.     Next i
    
21.     Cells(n, 1).Resize(UBound(arr3), UBound(arr3, 2)) = arr3
    
22. End Sub

复制代码

sunjing-zxl

附件： VBA＿鼠标选取当前列自定义排序-求修改代码-sj.rar (18.52 KB, 下载次数: 17)

2012-2-6 20:34 上传

点击文件名下载附件

yjwdjfqb

爱疯 发表于 2012-2-6 20:23
从图中代码看，目的是：
1）添加一个自定义序列
2）应用在某一区域

谢谢版主，第一步，是这样的

假如附件中，用鼠标在C4单元格中点一下，那么这里，我们排序的起始位置就是C4，终止位置就是C列中最后一个有数据的单元格。

排序的操作区域就是C4（包括C4这一行）以下所有有数据的行。（排序按“选定扩展区域的方式排序”）

第一步就是鼠标点击某一个单元格，然后就确定了排序的操作区域和排序的操作区域。

yjwdjfqb

sunjing-zxl 发表于 2012-2-6 20:35
附件：

老师，当我不，测试时，一点宏命令就什么数据就没有了

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.     '设置自定义排序的顺序
   
5.     arr1 = Array("外妇科", "手术室", "内儿科", "西医科", "中医科", "耳鼻喉科", "放射科", "检验科", "B超室", "口腔科", "针灸科", "西药房", "中药房", "收费室", "疾控科", "合管办", "后勤科")
   
6. 
   
7.     n = ActiveCell.Row    '获取活动单元格行号
   
8.     m = [A65536].End(xlUp).Row
   
9.     If n = 1 Or n > m Then
   
10.         MsgBox "活动行超出范围,不能排序"
    
11.         Exit Sub
    
12.     End If
    
13.     arr2 = Range(Cells(n, 1), Cells(m, "N"))    '活动单元格至最后一行数据赋值给数组arr1
    
14.     ReDim arr3(1 To UBound(arr2), 1 To UBound(arr2, 2))
    
15.     m = 0    '计数变量
    
16.     For i = 0 To UBound(arr1)
    
17.         For j = 1 To UBound(arr2)
    
18.             If arr1(i) = arr2(j, 3) Then
    
19.                 m = m + 1
    
20.                 For k = 1 To UBound(arr2, 2)
    
21.                     arr3(m, k) = arr2(j, k)
    
22.                 Next k
    
23.             End If
    
24.         Next j
    
25.     Next i
    
26.     Cells(n, 1).Resize(UBound(arr3), UBound(arr3, 2)) = arr3
    
27.     MsgBox "排序完成"
    
28. End Sub

复制代码

yjwdjfqb

sunjing-zxl 发表于 2012-2-6 20:50
试试这个

老师，当工作表改变时，执行宏命令就会删除全部数据。

我目的是当工作表改变是时，不改变代码，就能正确排序。

sunjing-zxl

你工作表要改成什么样子。
该不会是大变样把

爱疯

还是不大理解，只好猜了。

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

复制代码

只修改了排序区域

c0 = ActiveCell.Row
c1 = ActiveCell.End(xlDown).Row
With Range(Cells(c0, "c"), Cells(c1, "p"))
'设置排序的起始单元格
.Sort key1:=ActiveCell, order1:=xlAscending, _
Header:=xlGuess, OrderCustom:=i + 1