楼主
xyh9999 |
- Public Function Lqc_Array_Sort(Array_, Key1, Order) '(Array_[将要排序的数组], Key1[垂直数组(y,x)中x，像表格中的第Key1列作关键字], Order[=1,升序;<>1,降序])
- '李秋才注:本函数为自编函数,运行速度非常快!
- '以下的For…Next 是判断数组维数
- hhhh1 = 1: hhhh2 = 1: llll1 = 1: llll2 = 1
- For iii = 1 To 4
- On Error Resume Next
- Err.Clear
- tt = UBound(Array_, iii)
- If Err.Number = 9 Then AD = iii - 1: Exit For 'AD,数组维数
- Next
- On Error GoTo 0
- '-------------------------------
- '以下的IF…Then…即若是一维通过转置为二维，若是二维以上则Exit Function
- If AD = 2 Then
- If Not (Key1 >= 1 And Key1 <= UBound(Array_, 2) - LBound(Array_, 2) + 1) Then Exit Function
- hhhh1 = LBound(Array_, 1)
- hhhh2 = UBound(Array_, 1)
- llll1 = LBound(Array_, 2)
- llll2 = UBound(Array_, 2)
- ElseIf AD = 1 Then
- hhhh1 = LBound(Array_, 1)
- hhhh2 = UBound(Array_, 1)
- Array_ = Application.Transpose(Array_)
- Key1 = 1
- llll1 = 1
- llll2 = 1
- Else
- Exit Function
- End If
- '-------------------------------
- ls_arr_nam0 = ActiveSheet.Name
- ls_arr_nam = Format(Now, "MMDDHHMMSS") & Format(Round(Rnd() * 100000, 0), "000000")
- With ThisWorkbook.Sheets.Add
- .Name = ls_arr_nam
- End With
- ThisWorkbook.Sheets(ls_arr_nam0).Activate
- ThisWorkbook.Sheets(ls_arr_nam).Cells.ClearContents
- ThisWorkbook.Sheets(ls_arr_nam).Cells(1, 1).Resize(hhhh2 - hhhh1 + 1, llll2 - llll1 + 1).Value = Array_
- If Order = 1 Then
- ThisWorkbook.Sheets(ls_arr_nam).Cells(1, 1).Resize(hhhh2 - hhhh1 + 1, llll2 - llll1 + 1).Sort Key1:=ThisWorkbook.Sheets(ls_arr_nam).Cells(1, Key1), Order1:=xlAscending, Header:=xlGuess, _
- OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod _
- :=xlPinYin, DataOption1:=xlSortNormal
- Else
- ThisWorkbook.Sheets(ls_arr_nam).Cells(1, 1).Resize(hhhh2 - hhhh1 + 1, llll2 - llll1 + 1).Sort Key1:=ThisWorkbook.Sheets(ls_arr_nam).Cells(1, Key1), Order1:=xlDescending, Header:=xlGuess, _
- OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod _
- :=xlPinYin, DataOption1:=xlSortNormal
- End If
- If hhhh1 = 1 And llll1 = 1 Then
- ReDim Lqc_Array_SortX(hhhh1 To hhhh2, llll1 To llll2) As Variant
- Lqc_Array_SortX = ThisWorkbook.Sheets(ls_arr_nam).Cells(1, 1).Resize(hhhh2 - hhhh1 + 1, llll2 - llll1 + 1).Value
- Lqc_Array_Sort = Lqc_Array_SortX
- Else
- If AD = 2 Then
- Lqc_Array_Sort_ls = ThisWorkbook.Sheets(ls_arr_nam).Cells(1, 1).Resize(hhhh2 - hhhh1 + 1, llll2 - llll1 + 1).Value
- ReDim Lqc_Array_SortX(hhhh1 To hhhh2, llll1 To llll2) As Variant
- For i = hhhh1 To hhhh2
- For j = llll1 To llll2
- Let Lqc_Array_SortX(i, j) = Lqc_Array_Sort_ls(i - hhhh1 + 1, j - llll1 + 1)
- Next j
- Next i
- Lqc_Array_Sort = Lqc_Array_SortX
- Else
- If AD = 1 Then
- Lqc_Array_Sort_ls = Application.Transpose(ThisWorkbook.Sheets(ls_arr_nam).Cells(1, 1).Resize(hhhh2 - hhhh1 + 1, llll2 - llll1 + 1).Value)
- ReDim Lqc_Array_SortY(hhhh1 To hhhh2) As Variant
- For i = hhhh1 To hhhh2
- Let Lqc_Array_SortY(i) = Lqc_Array_Sort_ls(i - hhhh1 + 1)
- Next i
- Lqc_Array_Sort = Lqc_Array_SortY
- End If
- End If
- End If
- Application.DisplayAlerts = False '不进行提示
- ThisWorkbook.Sheets(ls_arr_nam).Delete
- Application.DisplayAlerts = True '进行提示
- End Function
|
