VBA 代码不是多而是精

楼主
研究研究

原作者要求优化VBA代码

q:我这儿有一个VBA自定义多方式排序的代码，很实用，但存在着一个问题，就是，少数据时，排序很快，如果多数据时，就很慢，甚至程序无响应。

A:但是原代码的思路过于复杂。方法和手段过于绕弯经本人测试。排序一个自定义名称为【职称】整整用了我488.秒以上
经优化后才2秒左右

Q:

Sub 自定义排序()
Dim KeyWD, iKey, iUseKey
Dim sh As Worksheet
Dim c As Range, cS As Range, cZ As Range, cX As Range
Dim r&, rE&, rZ&, col%, strX$, i&, iTimer
Set KeyWD = CreateObject("Scripting.Dictionary")
On Error Resume Next
'-----需改动的变量------开始
'-----自定义的序列，这里还可以增加自定义排序的顺序，可以增加多项。
KeyWD("科室") = "外妇科，手术室，内儿科，西医科，中医科，耳鼻喉科，放射科，检验科，B超室，口腔科，针灸科，西药房，中药房，收费室，疾控科，合管办，后勤科"
KeyWD("性别") = "男，女"
KeyWD("级别") = "中级，初级"
KeyWD("受聘专业") = "医生，护士"
strX = "序号" '序号，用处是，自动查找，工作有中，序号位置，但一个工作表中，不能有第二个序号，字符出现，否则，不能正确的重新编写序号，本句目的是，不会因为列与行的改变而改变编号位置。
Set sh = ActiveSheet '操作的工作表，不需要设置操作工作表变量，操作的就是当前工作表。
'-----需改动的变量------结束
Set cS = Application.InputBox("请选择要排序列的标题单元格：", Type:=8)
'If cS Is Nothing Then MsgBox "取消排序！": Exit Sub '这一句，是表示有“取消排序”提示。
If cS Is Nothing Then: Exit Sub '这一句，是表示无“取消排序”提示。
Set cX = cS.EntireRow.Cells.Find(strX, , xlValues, xlWhole)
Set cS = cS.Cells(2, 1)
Application.ScreenUpdating = False
On Error GoTo 1000
iTimer = Timer
With sh
r = cS.Row '开始排序的行数
col = cS.Column '排序关键字所在列
rE = .UsedRange.Row + .UsedRange.Rows.Count - 1 '末**
For i = rE To r Step -1
If Application.WorksheetFunction.CountA(.Rows(i)) Then
rE = i
Exit For
End If
Next
'If MsgBox(rE, vbOKCancel) <> vbOK Then GoTo 1000 '此句为调试代码时使之用。
iUseKey = cS.Offset(-1).Value
'----先用系统自带的排序
.Rows(r & ":" & rE).Sort Key1:=cS, Order1:=xlAscending
If KeyWD.Exists(iUseKey) Then
iKey = Split(KeyWD(iUseKey), "，") '存储；自定义序列。“，”这个表示自定义排序的分隔符号，同变量是的“，”，也就是把排序的关健字的分隔符，以前(狂人狂笑笑人狂)网友是用“|”来分隔的，由于，在输入时，不好输入，所以改成了“智能五笔”输入状态下的“，”符号便于输入。
Else
GoTo 2000
End If
'----排序，有关键字部分
For i = LBound(iKey) To UBound(iKey)
Set c = .Columns(col).Find(iKey(i), cS.Offset(-1), xlValues, xlWhole)
If Not c Is Nothing Then
Set cZ = c
rZ = 1
Do While c.Offset(1) = c
rZ = rZ + 1
Set c = c.Offset(1)
Loop
If cZ.Row <> r Then
cZ.EntireRow.Resize(rZ).Cut
cS.EntireRow.Insert Shift:=xlDown
End If
r = r + rZ
Set cS = .Cells(r, col)
End If
Next
If r > rE Then GoTo 2000
'----排序，无关键字部分
rZ = r
For r = r To rE
If .Cells(r, col).Value <> "" Then
If r <> rZ Then
sh.Rows(r).Cut
sh.Rows(rZ).Insert Shift:=xlDown
End If
rZ = rZ + 1
End If
Next
2000:
'----写入序号
If Not cX Is Nothing Then
With cX
For r = 1 To rE - cX.Row
.Offset(r).Value = r
Next
End With
End If
End With
Application.ScreenUpdating = True
MsgBox "排序完成！用时" & Format(Timer - iTimer, "0.0秒") '计算整个排序过程用时多少，如果不需要直接注释掉即可。
Exit Sub
1000:
Application.ScreenUpdating = True
MsgBox "发生未知错误！请联系作者", vbCritical
End Sub
'-----自定义排序代码------结束

Sub Macro1()
Set cS = Application.InputBox("请选择要排序列的标题单元格：", Type:=8)
If cS Is Nothing Then: Exit Sub
'Set cS = cS.Cells(2, 1)
r = cS.Row '开始排序的行数
col = cS.Column '排序关键字所在列
iTimer = Timer
Range("C3:BK5003").Sort Key1:=Cells(r, col), Order1:=xlAscending, Header:=xlGuess '直接用关键字对区域经行排序
MsgBox Timer - iTimer
End Sub

宏＿自下定义排序（多数据）.rar

2楼
MMonica605

强~