Hàm sắp xếp tăng, giảm bằng VBA

  • Thread starter Hồng Phương
  • Ngày gửi
H

Hồng Phương

Guest
Em chào các anh chị, giúp em hàm sắp xếp các giá trị tăng và giảm dần với ạ.
Em xin cảm ơn!
Sắp xếp tăng dầnSắp xếp giảm dần
1​
0​
15​
3​
1​
9​
0​
3​
5​
4​
4​
4​
5​
5​
3​
9​
9​
1​
15​
15​
0​
 

Bandit

Thành viên
VBA thì mình không biết cách viết, nhưng trường hợp trên vẫn sử dụng hàm có sẵn trong Excel được nên xin đưa ra cách giải quyết vấn đề trên như hình
Bạn cần đăng nhập để thấy hình ảnh
 
H

Hồng Phương

Guest
VBA thì mình không biết cách viết, nhưng trường hợp trên vẫn sử dụng hàm có sẵn trong Excel được nên xin đưa ra cách giải quyết vấn đề trên như hình
Bạn cần đăng nhập để thấy hình ảnh
Cảm ơn bạn rất nhiều, Trời ôi công thức này mình cũng dùng rồi mà nó cứ quên.
 
H

Hồng Phương

Guest
Nhưng mình muốn sắp xếp bỏ qua dữ liệu trùng (Tức là có dữ liệu trùng thì bỏ qua)
 

tuhocvba

Administrator
Thành viên BQT
Nhưng mình muốn sắp xếp bỏ qua dữ liệu trùng (Tức là có dữ liệu trùng thì bỏ qua)
Dữ liệu demo không thể hiện là có thể trùng lặp, trong nội dung bài viết #1 cũng không nói đến việc này. Vậy mà ở #4 bỗng dưng lại nhắc tới việc này là không đúng.
Tuy nhiên đây là box thành viên tự giúp nhau nên diễn đàn không can thiệp.
Bạn có thể dùng sort để sắp xếp dữ liệu tăng giảm. Tuy nhiên đây không phải là hàm, đây là thủ tục macro.
 
H

Hồng Phương

Guest
Dữ liệu demo không thể hiện là có thể trùng lặp, trong nội dung bài viết #1 cũng không nói đến việc này. Vậy mà ở #4 bỗng dưng lại nhắc tới việc này là không đúng.
Tuy nhiên đây là box thành viên tự giúp nhau nên diễn đàn không can thiệp.
Bạn có thể dùng sort để sắp xếp dữ liệu tăng giảm. Tuy nhiên đây không phải là hàm, đây là thủ tục macro.
Thế anh giúp em với, hàm này quan trọng mà anh.
 

tuhocvba

Administrator
Thành viên BQT
Tự làm đi, đây là box thành viên tự giúp nhau mà.
Quan trọng với tùy người và tùy thời điểm thôi. Vậy quan trọng như thế, ủng hộ diễn đàn đi, rồi các admin ra tay cho.
Sort:
 
H

Hồng Phương

Guest
Tự làm đi, đây là box thành viên tự giúp nhau mà.
Quan trọng với tùy người và tùy thời điểm thôi. Vậy quan trọng như thế, ủng hộ diễn đàn đi, rồi các admin ra tay cho.
Sort:
Anh oi, nhưng mà em thick hàm cơ anh oi
Anh làm giúp em với.
 

tuhocvba

Administrator
Thành viên BQT
Thích hàm cũng làm được, nhưng đây là box thành viên tự giúp nhau, anh là admin nên anh không làm đâu, nhưng sẽ phá lệ nếu nhận được ủng hộ vào đây:
Thông tin ủng hộ diễn đàn:
Tài khoản Ngân hàng thương mại cổ phần Ngoại thương Việt Nam Vietcombank, số tài khoản: 0011003264055
Chi nhánh Quận Hoàn Kiếm, Hà Nội.
Chủ tài khoản: Phạm Minh Hoàng.
 

thanhphong

Thành viên
Tôi không hiểu bạn muốn gì, giải pháp ở #2 đưa ra là đúng, giải quyết cả trùng lặp rồi.
Bạn cần đăng nhập để thấy hình ảnh
 
H

Hồng Phương

Guest
Tôi không hiểu bạn muốn gì, giải pháp ở #2 đưa ra là đúng, giải quyết cả trùng lặp rồi.
Bạn cần đăng nhập để thấy hình ảnh
Em cảm ơn anh, nhưng ý tưởng của em là không lấy trùng cơ anh oi.
Anh giúp em với.
 

thanhphong

Thành viên
Với dữ liệu như thế này thì kết quả kỳ vọng là như thế nào?
Bạn cần đăng nhập để thấy hình ảnh
 
L

LeonardLof

Guest
Bạn thử:
Mã:
Function sapxep(ByVal mang As Range, ByVal tangdan As Boolean, ByVal vt As Long) As String
    Dim olit, arr As Variant, i As Long, a As Long, t, s As String
    Set olit = CreateObject("System.Collections.SortedList")
        For Each t In mang
          
           If Not olit.ContainsKey(t.Value) Then
              olit.Add t.Value, ""
           End If
        Next
        ReDim arr(1 To olit.Count)
        If vt <= 0 Or vt > olit.Count Then
            sapxep = "Not Found"
            Set olit = Nothing
            Exit Function
        End If
        
        If tangdan = True Then
           For i = 0 To olit.Count - 1 Step 1
               a = a + 1
               arr(a) = olit.getkey(i)
           Next i
        Else
            For i = olit.Count - 1 To 0 Step -1
               a = a + 1
               arr(a) = olit.getkey(i)
            Next i
        End If
    Set olit = Nothing
        sapxep = CStr(arr(vt))
End Function
Kết quả:
Bạn cần đăng nhập để thấy hình ảnh

Code này yêu cầu máy tính phải cài .net framework vì ở trên tớ dùng sortlist. Code này bạn sẽ không học hỏi được gì ở thuật toán.
Sortlist bạn tham khảo ở đây:
 

bvtvba

Thành viên tích cực
Code #13 dùng sortlist thì tiện cho người code nhưng có điểm hạn chế là máy tính phải cài .net framework. Ngoài ra nhìn vào đây thì không học hỏi được thuật toán sắp xếp. Do đó, tôi đề xuất code sau cho kết quả tương đương, mà lại không dùng sortlist.
Mã:
Function sapxep(ByVal mang As Range, ByVal tangdan As Boolean, ByVal vt As Long) As String
    Dim arr As Variant, brr As Variant, i As Long, t, cnt As Long
    Dim kttt As String, keytem As String
    
    
    arr = mang.Value
    arr = WorksheetFunction.Transpose(arr)
    ReDim brr(LBound(arr) To UBound(arr))
    cnt = 0
        For i = LBound(arr) To UBound(arr) Step 1
            keytem = CStr(arr(i)) & "_tuhocvba.net_"
            If InStr(1, kttt, keytem) = 0 Then
                cnt = cnt + 1
                kttt = kttt & keytem & ";"
                
                brr(cnt) = arr(i)
            End If
        Next i
        
        If vt <= 0 Or vt > cnt Then
            sapxep = "Not Found"
            
            Exit Function
        End If
        
      
        If cnt > 1 Then
            Call sapxepmang(brr, tangdan, cnt)
        End If
        sapxep = CStr(brr(vt))
End Function
Sub sapxepmang(ByRef brr As Variant, ByVal tangdan As Boolean, ByVal cnt)
    Dim i As Long
    Dim j As Long
    Dim temp
    If tangdan = True Then
        For i = LBound(brr) To cnt - 1 Step 1
            For j = i + 1 To cnt Step 1
                If Val(CStr(brr(i))) > Val(CStr(brr(j))) Then
                    temp = brr(i)
                    brr(i) = brr(j)
                    brr(j) = temp
                End If
            Next j
        Next i
    Else
        For i = LBound(brr) To UBound(brr) - 1 Step 1
            For j = i + 1 To UBound(brr) Step 1
                If Val(CStr(brr(i))) < Val(CStr(brr(j))) Then
                    temp = brr(i)
                    brr(i) = brr(j)
                    brr(j) = temp
                End If
            Next j
        Next i
    End If
    
End Sub
Kết quả tương tự:
Bạn cần đăng nhập để thấy hình ảnh
 

thanhphong

Thành viên
Code #14 nói chung là ổn, nhưng còn trường hợp Range là Nothing, tức người dùng quên chẳng nhập gì thì cần code cho trường hợp này.
Ngoài ra có thể thay "Not Found" là ký tự rỗng "".
Như vậy ta có thể sửa là:
Mã:
Function sapxep(ByVal mang As Range, ByVal tangdan As Boolean, ByVal vt As Long) As String
    Dim arr As Variant, brr As Variant, i As Long, t, cnt As Long
    Dim kttt As String, keytem As String
    
    If mang Is Nothing Then
        sapxep = ""
        Exit Function
    End If
    arr = mang.Value
    arr = WorksheetFunction.Transpose(arr)
    ReDim brr(LBound(arr) To UBound(arr))
    cnt = 0
        For i = LBound(arr) To UBound(arr) Step 1
            keytem = CStr(arr(i)) & "_tuhocvba.net_"
            If InStr(1, kttt, keytem) = 0 Then
                cnt = cnt + 1
                kttt = kttt & keytem & ";"
                
                brr(cnt) = arr(i)
            End If
        Next i
        
        If vt <= 0 Or vt > cnt Then
            sapxep = ""
            
            Exit Function
        End If
        
      
        If cnt > 1 Then
            Call sapxepmang(brr, tangdan, cnt)
        End If
        sapxep = CStr(brr(vt))
End Function
Sub sapxepmang(ByRef brr As Variant, ByVal tangdan As Boolean, ByVal cnt)
    Dim i As Long
    Dim j As Long
    Dim temp
    If tangdan = True Then
        For i = LBound(brr) To cnt - 1 Step 1
            For j = i + 1 To cnt Step 1
                If Val(CStr(brr(i))) > Val(CStr(brr(j))) Then
                    temp = brr(i)
                    brr(i) = brr(j)
                    brr(j) = temp
                End If
            Next j
        Next i
    Else
        For i = LBound(brr) To UBound(brr) - 1 Step 1
            For j = i + 1 To UBound(brr) Step 1
                If Val(CStr(brr(i))) < Val(CStr(brr(j))) Then
                    temp = brr(i)
                    brr(i) = brr(j)
                    brr(j) = temp
                End If
            Next j
        Next i
    End If
    
End Sub
Bây giờ bỏ cột Số thứ tự(STT) đi, ta thay bằng Rows($1:1) giống như cách sử dụng ở bài #2.
Bạn cần đăng nhập để thấy hình ảnh


Bây giờ giả sử vùng Range chẳng nhập cái gì vào, thì sẽ ra sao đây?
Bạn cần đăng nhập để thấy hình ảnh


Kết quả này là hợp lý.
Code ở #14 giúp chúng ta hiểu được thuật toán sắp xếp hơn là cách dùng Sortlist.
 
A

Andreasepq

Guest
Để xét tính tồn tại mà không dùng sortlist hoặc dictionary, thì chỗ này nên chặn cả ở đầu, code có thể sửa như sau (dòng 14):
Mã:
Function sapxep(ByVal mang As Range, ByVal tangdan As Boolean, ByVal vt As Long) As String
    Dim arr As Variant, brr As Variant, i As Long, t, cnt As Long
    Dim kttt As String, keytem As String
    
    If mang Is Nothing Then
        sapxep = ""
        Exit Function
    End If
    arr = mang.Value
    arr = WorksheetFunction.Transpose(arr)
    ReDim brr(LBound(arr) To UBound(arr))
    cnt = 0
        For i = LBound(arr) To UBound(arr) Step 1
            keytem = "_tuhocvba.net_" & CStr(arr(i)) & "_tuhocvba.net_"
            If InStr(1, kttt, keytem) = 0 Then
                cnt = cnt + 1
                kttt = kttt & keytem & ";"
                
                brr(cnt) = arr(i)
            End If
        Next i
        
        If vt <= 0 Or vt > cnt Then
            sapxep = ""
            
            Exit Function
        End If
        
      
        If cnt > 1 Then
            Call sapxepmang(brr, tangdan, cnt)
        End If
        sapxep = CStr(brr(vt))
End Function
Sub sapxepmang(ByRef brr As Variant, ByVal tangdan As Boolean, ByVal cnt)
    Dim i As Long
    Dim j As Long
    Dim temp
    If tangdan = True Then
        For i = LBound(brr) To cnt - 1 Step 1
            For j = i + 1 To cnt Step 1
                If Val(CStr(brr(i))) > Val(CStr(brr(j))) Then
                    temp = brr(i)
                    brr(i) = brr(j)
                    brr(j) = temp
                End If
            Next j
        Next i
    Else
        For i = LBound(brr) To UBound(brr) - 1 Step 1
            For j = i + 1 To UBound(brr) Step 1
                If Val(CStr(brr(i))) < Val(CStr(brr(j))) Then
                    temp = brr(i)
                    brr(i) = brr(j)
                    brr(j) = temp
                End If
            Next j
        Next i
    End If
    
End Sub
 
Top