Gia sư Cần Thơ, Dạy Kèm Cần Thơ

VỮNG TIN - TIẾP BƯỚC - THÀNH CÔNG


Sắp xếp mảng dữ liệu không sử dụng vòng lặp

Share
avatar
admin
Admin
Admin

Tổng số bài gửi : 1207
Points : 3010
Join date : 11/11/2009
Age : 36
Đến từ : Cần Thơ

Sắp xếp mảng dữ liệu không sử dụng vòng lặp

Bài gửi  admin on Fri Jul 01, 2011 3:37 pm

Sắp xếp mảng dữ liệu không sử dụng vòng lặp
Xin gửi các bạn 1 hàm sắp xếp mảng dữ liệu không sử dụng vòng lặp. arr là mảng cần sắp xếp, isText=true là sắp xếp mảng kiểu chuỗi, ngược lại là kiểu số(mặc định là kiểu số), isDESC=true là sắp xếp giảm dần, ngược lại là tăng dần(mặc định là tăng dần).
Đây là thủ thuật lợi dụng tính năng sắp xếp có sẵn trên ngôn ngữ khác(JavaScript) để thực hiện, có hạn chế là phải chuyển qua 1 chuỗi trung gian nên khi trả về luôn là mảng chuỗi, thích hợp cho việc hiển thị, còn dùng để tính toán thì sẽ có hạn chế. Về tốc độ thì tôi chưa test kỹ, nhưng có vẻ khả quan hơn phương pháp sử dụng vòng lặp thông thường.

Code:
Public Function SortArray(arr, Optional isText As Boolean = False, Optional isDESC As Boolean = False)
    Dim sCommand As String
    sCommand = "('" & Join(arr, vbBack) & "').split('" & vbBack & "').sort("
    If isText Then
        sCommand = sCommand & ")"
    Else
        sCommand = sCommand & "function(a,b){return (a-b)})"
    End If
    If isDESC Then sCommand = sCommand & ".reverse()"
    sCommand = sCommand & ".join('" & vbBack & "')"
    Dim objSC
    Set objSC = CreateObject("MSScriptControl.ScriptControl")
    objSC.Language = "JavaScript"
    SortArray = Split(objSC.Eval(sCommand), vbBack)
End Function
Sưu tầm: http://www.giaiphapexcel.com/forum/showthread.php?38005-S%E1%BA%AFp-x%E1%BA%BFp-m%E1%BA%A3ng-d%E1%BB%AF-li%E1%BB%87u-kh%C3%B4ng-s%E1%BB%AD-d%E1%BB%A5ng-v%C3%B2ng-l%E1%BA%B7p&
avatar
admin
Admin
Admin

Tổng số bài gửi : 1207
Points : 3010
Join date : 11/11/2009
Age : 36
Đến từ : Cần Thơ

Sort mảng 2 chiều

Bài gửi  admin on Fri Jul 01, 2011 3:41 pm

Code:
Function Sort2DArray(sArray, ColIndex As Long, Order As Boolean, HasTitle As Boolean)
  Dim TmpArr, Title, i As Long, j As Long, Dic, SortArr, SortArr2
  Dim Arr, iR As Long, Tmp, Chk As Boolean
  Set Dic = CreateObject("Scripting.Dictionary")
  On Error Resume Next
  TmpArr = sArray
  Chk = IsNumeric(TmpArr(LBound(TmpArr, 1) - HasTitle, ColIndex))
  For i = LBound(TmpArr, 1) - HasTitle To UBound(TmpArr, 1)
    Tmp = TmpArr(i, ColIndex)
    If Dic.Exists(Tmp) Then
      Tmp = Tmp & vbTab & i
      TmpArr(i, ColIndex) = Tmp
    End If
    Dic.Add Tmp, i
  Next
  Arr = TmpArr
  SortArr = Sort1DArray(Dic.Keys, Not Chk, Order)
  For i = LBound(TmpArr, 1) - HasTitle To UBound(TmpArr, 1)
    iR = Dic.Item(SortArr(i + HasTitle - 1))
    For j = LBound(sArray, 2) To UBound(sArray, 2)
      Arr(i, j) = Replace(TmpArr(iR, j), vbTab & iR, "")
    Next
  Next
  Sort2DArray = Arr
End Function 

CẢI TIẾN
Code:
Function Sort2DArray(sArray, ColIndex As Long, Order As Boolean, HasTitle As Boolean)
  Dim TmpArr, i As Long, j As Long, Dic, SortArr
  Dim Arr, iR As Long, Tmp, Chk As Boolean
  Set Dic = CreateObject("Scripting.Dictionary")
  On Error Resume Next
  TmpArr = sArray
  ColIndex = ColIndex + LBound(TmpArr, 2) - 1
  Chk = IsNumeric(TmpArr(LBound(TmpArr, 1) - HasTitle, ColIndex))
  For i = LBound(TmpArr, 1) - HasTitle To UBound(TmpArr, 1)
    Tmp = TmpArr(i, ColIndex)
    If Dic.Exists(Tmp) Then
      If Chk Then
        Tmp = Tmp + i / (10 ^ 10)
      Else
        Tmp = Tmp & vbTab & i
      End If
      TmpArr(i, ColIndex) = Tmp
    End If
    Dic.Add Tmp, i
  Next
  Arr = TmpArr
  SortArr = Sort1DArray(Dic.Keys, Not Chk, Order)
  For i = LBound(SortArr, 1) To UBound(SortArr, 1)
    If Chk Then
      iR = Dic.Item(CDbl(SortArr(i)))
    Else
      iR = Dic.Item(CStr(SortArr(i)))
    End If
    For j = LBound(TmpArr, 2) To UBound(TmpArr, 2)
      If Chk Then
        If j = ColIndex Then
          Arr(i + LBound(TmpArr, 1) - HasTitle, j) = TmpArr(iR, j) - iR / (10 ^ 10)
        Else
          Arr(i + LBound(TmpArr, 1) - HasTitle, j) = TmpArr(iR, j)
        End If
      Else
        Arr(i + LBound(TmpArr, 1) - HasTitle, j) = Replace(TmpArr(iR, j), vbTab & iR, "")
      End If
    Next
  Next
  Sort2DArray = Arr
End Function 

    Hôm nay: Wed Jan 17, 2018 10:11 am