EXCEL高手们VBA-排序慢的问题，怎么才能解决。。。。

yjwdjfqb

各位VBA高手们，帮我把这个问题解决下吧，我在好几个网站上，都
发了这个问题，都没有解决到，希望VBA高手们，帮帮忙，在不改变
表二的情况下，不改变我的使用功能和方法，使排序提快速度。

为什么表一，排序速度快，表二就不行，数据也不是很多呀。。。


期待VBA高手们修改下代码。。。或者按这个操作方法，重新写一个代码出来，

看一下原来的代码，就可以知道，具体功能了。。。


谢谢大家了。。。。

砂海

用excel 自带的排序即可。根本不用宏。
你的序列已经自定义。

yjwdjfqb

回复 砂海 的帖子

关键是，我有自定义的排序顺序

砂海

就是用你自定义的。
选中B2:M14
数据，排序，有标题行，主要关键字。

yjwdjfqb

回复 砂海 的帖子

老师，可以把你修改的文件传上来吧

蓝桥玄霜

可用增加自定义序列的方法，来排序，要比你自编的代码快很多的。
比如：
    Application.AddCustomList ListArray:=Array("医生", "护士")
    Range("C3:BK1503").Sort Key1:=Range("I4"), Order1:=xlAscending, Header:= _
        xlGuess, OrderCustom:=14

兰色幻想

Sub 排序()
  Dim cs As Range
  Dim rg As Range
    Set rg = Range("b2:m14") '筛选区域
    Set cs = Application.InputBox("请选择要排序列的标题单元格：", Type:=8)
        rg.Sort Key1:=cs, Order1:=xlAscending, Header:=xlGuess, _
        OrderCustom:=Choose(cs.Column, , , , 17, 19, , , 20, 18)
        
'在运行前先添加四个自定义序列，17替换成科室在自定义序列中的排序,18是男，女在自定义序列的中的序号，19是级别的序号，20是医生和护士的序号，
End Sub

yjwdjfqb

回复 兰色幻想 的帖子

老师，我还没有弄明白你的方法，把附件给我传下好吧，谢谢

兰色幻想

自定义序列是自保存自已的EXCEL里的，我传给也没用，程序就这些了

yjwdjfqb

回复 兰色幻想 的帖子

以这个代码为基础修改可以吗。。提高排序速度。。。

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
'-----自定义排序代码------结束