求助修改代码

1吧吧

求助修改代码

杨建营

条件太多了

xjl565135022

Sub SortData()
    Dim ws1 As Worksheet
    Set ws1 = ThisWorkbook.Sheets("Sheet1") ' 修改为你的工作表名
    Set ws3 = ThisWorkbook.Sheets("Sheet3") ' 修改为你的工作表名
    With ws1
        ' 假设我们要排序的是A1到B10这个区域
        ' Key1表示参照第一列(A列)进行排序
        ' Order1表示排序方式为升序(xlAscending)
        ' Header指定是否有标题，xlYes或xlNo
        ' Orientation表示按列排序(xlSortColumns)
        ' MatchCase表示是否区分大小写
        .Range("A1:E" & [E65536].End(3).Row).Sort Key1:=.Range("E1"), Order1:=xlDescending, Header:=xlNo, _
            OrderCustom:=1, MatchCase:=False, Orientation:=xlSortColumns
        .Range("A1:E" & [E65536].End(3).Row).Copy ws3.Range("B1")
    End With
End Sub

gwjkkkkk

Option Explicit
Sub TEST2()
    Dim ar
    Application.ScreenUpdating = False
   
    ar = Worksheets(1).[D1].CurrentRegion.Value
    bSort ar, 1, UBound(ar), 1, 2, 2, False
    With Worksheets(2)
        .[C1].CurrentRegion.Clear
        .[C1].Resize(UBound(ar), 2) = ar
        .Activate
    End With
   
    Application.ScreenUpdating = True
    Beep
End Sub

Function bSort(ByRef ar, ByVal iFirst&, ByVal iLast&, ByVal iLeft&, _
    ByVal iRight&, ByVal iKey&, Optional isOrder As Boolean = True)
    Dim i&, j&, k&, vTemp
   
    For i = iFirst To iLast - 1
        For j = iFirst To iLast + iFirst - 1 - i
            If ar(j, iKey) <> ar(j + 1, iKey) Then
                If ar(j, iKey) < ar(j + 1, iKey) Xor isOrder Then
                    For k = iLeft To iRight
                        vTemp = ar(j, k)
                        ar(j, k) = ar(j + 1, k)
                        ar(j + 1, k) = vTemp
                    Next
                End If
            End If
        Next j
    Next i
End Function

gwjkkkkk

.................