Một số thuật toán về sort mảng

3 Responses

1. hands says:

   17/01/2023 at 9:25 am

   Thuật toán Sắp xếp nổi bọt Bubble Sort

   Option Explicit
   
   Sub Bubble_sort(A() As Long, n As Long)
   Dim I As Long, j As Long
         For I = 0 To n - 1 Step 1
               For j = n - 1 To I + 1 Step -1
                   If (A(j) < A(j - 1)) Then
                           Call Swap(A(j), A(j - 1))
                  End If
              Next j
         Next I
   End Sub

   K5gpmaQg7QM
   Mô phỏng thuật toán

   Sắp xếp nổi bọt cải tiến ShakeSort

   Option Explicit
   Sub ShakeSort(A() As Long, N As Long)
   Dim I As Long, J As Long
   Dim Left As Long, Right As Long, k As Long
   Left = 0
   Right = N - 1
   k = N - 1
   
   I = N - 1
   Do While (Left < Right)
       For J = Right To Left + 1 Step -1
            If (A(J) < A(J - 1)) Then
               Call Swap(A(J), A(J - 1))
               k = J
            End If
       Next J
       Left = k
   
   For J = Left To Right - 1 Step 1
            If (A(J) > A(J + 1)) Then
               Call Swap(A(J), A(J + 1))
               k = J
            End If
        Next
            Right = k
   Loop
   End Sub

   Sắp xếp nhanh Quick_Sort

   Option Explicit
   Sub Quicksort(a() As Long, Left As Long, Right As Long)
   Dim i As Long, j As Long, x As Long, y As Long
   i = Left
   j = Right
   x = a(Int((Left + Right) / 2))
    Do
       Do While (a(i) < x And i < Right)
           i = i + 1
       Loop
   
   Do While (a(j) > x And j > Left)
           j = j - 1
       Loop
       If (i <= j) Then
   
   y = a(i)
           a(i) = a(j)
           a(j) = y
           i = i + 1
           j = j - 1
       End If
   
   Loop Until i > j
   If (Left < j) Then
       Call Quicksort(a, Left, j)
    End If
   If (i < Right) Then
       Call Quicksort(a, i, Right)
   End If
   End Sub
   
   Sub Quick_Sort(a() As Long, n As Long)
      Call Quicksort(a, 0, n - 1)
   End Sub

   0-7bdG4wgoM

   Thuật toán Merger Sort

   Option Explicit
   
   Sub Merger_Sort(a() As Long, Start As Long, End_ As Long)
       If (End_ - Start < 1) Then
          Exit Sub
       End If
   Dim Mid_ As Long
     Mid_ = Int((Start + End_) / 2)
       Call Merger_Sort(a, Start, Mid_)
       Call Merger_Sort(a, Mid_ + 1, End_)
       Call Merger(a, Start, End_)
   End Sub

   Sub Merger(a() As Long, Start As Long, End_ As Long)
   
   Dim Mid_ As Long, i As Long, j As Long
   Dim temp As Long
   Dim k As Long
     Mid_ = Int((Start + End_) / 2)
     i = Start
     j = Mid_ + 1
   
   Do While ((i <= j) And (j <= End_))
   
   If (a(i) > a(j)) Then
   
   temp = a(j)
               For k = j To i + 1 Step -1
                   a(k) = a(k - 1)
               Next
               a(i) = temp
               j = j + 1
            End If
               i = i + 1  
      Loop
   End Sub

   Call Merger_Sort(Arr, 0, n – 1)

   Reply
2. hands says:

   17/01/2023 at 9:28 am

   Mình thì rất quan tâm đến kiểu sort trong mảng theo kiểu quicksort, nhưng sort 1 bảng nhiều cột và có tùy chọn ưu tiên giống như sort trên sheet mà chưa biết làm thế nào.
   Ai có cách thì vui lòng gởi code lên cho mọi người tham khảo với.

   mới nghỉ thôi không biết có đúng hay không? có thể khi chọn các kiểu sort thì nó đã ghép lại thành 1 cột tổng sau đó sort dựa vào cột tổng? đó mới là ý tưởng thôi

   Mình cũng đã từng thử như thế. Cũng Sort được nhưng tiếc thay là kết quả ra tiếu lâm lắm. Vì khi ghép lại với nhau mọi thứ biết thành chuỗi và kết quả ra vui mắt ghê
   Khi ghép lại code hiểu 1 143 nhỏ hơn 1 43
   2014

   Ghép nhau để sort thì phải có "chiêu", không thể ghép thoải mái được (ít nhất là làm sao cho chuỗi sau khi ghép có số ký tự bằng nhau toàn bộ)
   Lúc trước có lần cũng định tiếp tục vụ sort mảng này nhưng.. lười. Với lại tôi cũng chưa có nhu cầu sort 2 cột làm gì cả

   Cho dù sau khi ghép và các chuỗi có độ dài bằng nhau cũng chết anh ơi.
   Ví dụ ngày 01-10-14 sẽ nhỏ hơn 30-09-14

   Nghiên cứu cho vui thôi chứ nếu muốn sort thì đập dữ liệu xuống sheet rồi sort cho khoẻ.

   Đang có ý tưởng mới, nếu code được em sẽ post lên. Đầu tiên sort theo yêu cầu 1, sau đó dùng đệ quy ngắt những dòng trùng nhau sort theo cấp độ 2, và cứ thế cho hết các cấp độ sort, hy vọng là có thể sáng
   Có thể lập function

   Function LớnHơn (a,b,c,d) as Boolean
        If a>c then LớnHơn=True
        Elseif a<c then LớnHơn=False
        Else 
           If b>d then LớnHơn=True else LớnHơn=False
        End If
   End function

   Sau đó các so sánh trong phần sort, ví dụ bubble sort ở trên ta thay
   If a(j)<a(j-1) thành
   If LớnHơn(a(j-1,1),a(j-1,2),a(j,1),a(j,2))
   Mình để tên function tiếng Việt có dấu cho đỡ "phản cảm"!

   Sao anh không thử 1 code hoàn chỉnh cho anh em tham khảo với?
   Nói thiệt mình xem mấy cái so sánh đó như là "Đối Ngưu Đàn Cầm"

   Thảy cho sort cái hàm so sánh là đúng ý tưởng rồi. Nhưng đối với VBA viết hàm như vậy thì hơi hạn hẹp. Hàm phải nhận tham số gồm mảng, chỉ số 2 dòng cần so sánh, và một dãy array cho biết những cột nào cần so sánh, và so sánh theo chiều tăng hay giảm (mỗi cột). Hàm trả về -1: dòng 2 cần đi trước dòng 1; 0: hai dòng ngang nhau; 1: dòng 1 đi trước.

   Cái này tôi nhớ mang máng đã trả lời ở một bài hỏi về cách sort vùng trên excel theo kiểu của lệnh sort trên worksheet.

   Cái khó không phải ở hàm so sánh, mà khó ở chỗ làm cách nào chuyển vị hàng của mảng 2 chiều. Chả nhẽ mỗi lần cần chuyển vị thì chép từng cột?

   Code này tôi để đâu mất rồi. Để thứ hai vào sở kiếm xem.

   Em cũng không rõ kiểu sort này gọi là gì nữa, dễ viết nhất. Tạm thời code so sánh tăng 2 cột A, B; đọc ghi từng ô cho tốc độ chậm lại dễ so sánh.

   Function LH(a, b, c, d) As Boolean
        If a > c Then
              LH = True
        ElseIf a < c Then
              LH = False
        Else
              If b > d Then LH = True Else LH = False
        End If
   End Function
   Private Sub CommandButton1_Click()
           Application.ScreenUpdating = False
           Dim Rng As Range
           Set Rng = Sheet1.Range("A2:B10002")
           Dim Arr(0 To 10000) As Long
           Dim Brr(0 To 10000) As Long
           Dim N As Long, j&, tmp&
           N = 10000
           Sheet1.Range("C2:D10002").ClearContents
           Dim i As Long
             For i = 0 To N
               Arr(i) = Rng(i + 1, 1).Value
               Brr(i) = Rng(i + 1, 2).Value
           Next
           For i = 0 To N - 1
               For j = i + 1 To N
                  If LH(Arr(i), Brr(i), Arr(j), Brr(j)) Then
                    tmp = Arr(i)
                    Arr(i) = Arr(j)
                    Arr(j) = tmp
                    tmp = Brr(i)
                    Brr(i) = Brr(j)
                    Brr(j) = tmp
                   End If
               Next
           Next
   
   For i = 0 To N
               Range("C" & i + 2).Value = Arr(i)
               Range("D" & i + 2).Value = Brr(i)
           Next
        Application.ScreenUpdating = True
   End Sub

   Cái khó không phải ở hàm so sánh, mà khó ở chỗ làm cách nào chuyển vị hàng của mảng 2 chiều. Chả nhẽ mỗi lần cần chuyển vị thì chép từng cột?

   Nếu không chuyển vị thì có thể lập mảng 1 chiều để lập chỉ mục, chỉ chuyển vị trên mảng này, nhưng lúc ghi xuống range thì lại phải ghi từng hàng.

   Reply
3. hands says:

   17/01/2023 at 9:29 am

   Như đã hứa hôm thứ Bảy. Hôm nay tôi vào sở lục ra cái này.
   Chú ý rằng đây chỉ là code để chứng minh rằng có thể bắt chước cách sort trong bảng của Excel. Trên thực tế, nó vừa rắc rối vừa chậm hơn Excel nhiều.

   Chú ý thêm rằng code này tôi để giành tham khảo cho nên có thêm dòng "Attributre"

   Attribute VB_Name = "MultiColumnSortExample"
   
   Function SoSanh(a As Variant, r As Variant, i1 As Integer, i2 As Integer) As Integer
   ' compares two rows (i1 and i2) of an array a, using the rules array r
   ' returns: -1 if row i1 is less than row i2, 1 otherwise
   Dim I As Integer, f As Integer, s As Integer
   SoSanh = 0
   For I = LBound(r) To UBound(r)
       f = Abs(r(I)) ' column to compare
       If a(i1, f) <> a(i2, f) Then
           ' note that Sgn(r(i)) tells whether the comparison is ascend/descending
           If IsNumeric(a) And IsNumeric(b) Then
                SoSanh = Sgn(r(I)) * IIf(Val(a(i1, f)) <> Val(a(i2, f)), -1, 1)
           Else
                SoSanh = Sgn(r(I)) * IIf(a(i1, f) < a(i2, f), -1, 1)
           End If
           Exit For ' no need to compare the next columns
       End If
   Next I
   End Function
   
   Sub sapxep()
   Dim rg As Range
   Set rg = Range("a3:g6707")
   Dim ar As Variant, r(1 To 4) As Integer
   Dim idx() As Integer
   Dim rMx As Integer, cMx As Integer
   ar = rg.Value
   rMx = UBound(ar)
   cMx = UBound(ar, 2)
   r(1) = 1 ' column A ascending
   r(2) = 2 ' column B ascending
   r(3) = -3 ' column C desscending (negative value)
   r(4) = 5 ' column E ascending
   ReDim idx(1 To rMx)
   ' start sorting, using the index
   Dim I As Integer, J As Integer, K As Integer
   ' create the index array
   ' the idea is that sorting the array directly will involve too much copying
   ' thus during soritng, only the indices are shuffled around
   ' when it's all done, copy the whole array according to the index array
   For I = 1 To rMx
       idx(I) = I
   Next I
   Debug.Print "start sorting"; Timer
   ' Demo with bubble sort, although any sort can do
   'For I = 1 To rMx
   '    For J = I To rMx
   '        If SoSanh(ar, r, idx(J), idx(I)) < 0 Then
   '            K = idx(I)
   '            idx(I) = idx(J)
   '            idx(J) = K
   '        End If
   '    Next J
   'Next I
   Call QuickSort(ar, r, idx)
   Debug.Print "start copying back"; Timer
   ' using the index array to copy back, line by line
   Dim ar2 As Variant
   ReDim ar2(1 To rMx, 1 To cMx)
   For I = 1 To rMx
       For J = 1 To cMx
           ar2(I, J) = ar(idx(I), J)
       Next J
   Next I
   rg.Value = ar2
   Debug.Print "all done"; Timer
   End Sub
   
   Private Sub QuickSort(ByRef Values As Variant, ByRef Rules As Variant, ByRef IdxArray() As Integer, _
                   Optional ByVal Left As Long, Optional ByVal Right As Long)
   ' i (almost) always comment my codes
   ' however, this algorithim is too well known. I hope I can be excused this one time
     Dim I As Long
     Dim J As Long
     Dim K As Long
     Dim Item1 As Variant
     Dim Item2 As Variant
   
   On Error GoTo Catch
     If IsMissing(Left) Or Left = 0 Then Left = LBound(IdxArray)
     If IsMissing(Right) Or Right = 0 Then Right = UBound(IdxArray)
     I = Left
     J = Right
   
   Item1 = IdxArray((Left + Right)  2)
     Do While I < J
       Do While SoSanh(Values, Rules, IdxArray(I), IdxArray(Item1)) < 0 And I < Right
         I = I + 1
       Loop
       Do While SoSanh(Values, Rules, IdxArray(J), IdxArray(Item1)) > 0 And J > Left
         J = J - 1
       Loop
       If I < J Then
         K = IdxArray(I)
         IdxArray(I) = IdxArray(J)
         IdxArray(J) = K
       End If
       If I <= J Then
         I = I + 1
         J = J - 1
       End If
     Loop
     If J > Left Then Call QuickSort(Values, Rules, IdxArray, Left, J)
     If I < Right Then Call QuickSort(Values, Rules, IdxArray, I, Right)
     Exit Sub
   Catch:
     MsgBox Err.Description, vbCritical
   
   End Sub

   Chỗ
   If IsNumeric(a) And IsNumeric(b) Then
   SoSanh = Sgn(r(I)) * IIf(Val(a(i1, f)) <> Val(a(i2, f)), -1, 1)
   Chắc phải sửa thành val(a(i1,f))<val(a(i2,f))

   Cảm ơn bạn. Tôi gõ nhâm. Chỗ đó cần sửa <> thành <

   Reply