Sắp xếp số trong chuỗi

Thiên Thanh

Yêu THVBA
Các bạn trên diễn đàn viết giúp hàm này nhé
Cảm ơn
Bạn cần đăng nhập để thấy hình ảnh
 
T

thuthuy2000

Guest
Bạn có nghĩ bạn đang thiếu tôn trọng mọi người không?
Không thuyết minh vào bài viết.
Không sử dụng hình ảnh minh họa.

Người dùng phải download file của bạn về.
Xin hỏi, bạn đang cần mọi người, hay là mọi người xin đám để được code cho bạn vậy bạn ơi?
 

NhanSu

SMod
Thành viên BQT
@Thiên Thanh có phải là Hồng Phương không nhỉ? Em hay có đề bài rất lạ, có phải input xuất từ phần mềm nào đó ra không? Cách upload hình ảnh thì em xem
Ngoài ra em cần đưa link file demo, dễ nhất là upload lên mediafire.com
Mọi người nhắc nhau thì đầu tiên cũng nên nhẹ nhàng sẽ dễ tiếp thu hơn.
 
D

Deleted member 199

Guest
Quý Anh chị @Thiên Thanh thân mến.
Lời đầu tiên cho em gửi lời chúc sức khỏe tới quý anh chị.

Quý anh chị Thiên Thanh thân mến! Có lẽ quý anh chị đã đánh giá những người tham gia diễn đàn như bọn em quá cao. Có phải vì vậy mà bài viết của quý anh chị Thiên Thanh quá kiệm lời, không có hình ảnh và ngôn từ giải thích gì thêm.
Quý anh chị Thiên Thanh ơi! Đã bao giờ anh chị thử đứng vào lập trường của người đọc như bọn em chưa ạ.

Nếu quý anh chị cho phép, xin cho em được đòi hỏi ở anh chị mấy điều sau:
1-Đưa thuyết minh vào bài viết.
2- Đưa hình ảnh minh họa vào bài viết.


Nếu những đòi hỏi này gây nên những tổn thương ở trái tim mong manh dễ vỡ của quý anh chị, thì hãy cho phép em được xin lỗi. Em thật không biết phải diễn tả bằng từ ngữ nào để anh chị có thể hiểu được mong mỏi trên của em thật ra là rất chính đáng.

Một lần nữa, em cảm ơn quý anh chị vì đã tham gia diễn đàn cùng bọn em, đã tin tưởng giao bài tập để bọn em làm, đã đánh giá bọn em rất cao.
Chân thành cảm ơn.

Em của anh chị Thiên thanh: DuyHieu
 
Với bài toán của bạn:
INPUT: 00,33,44,33,33,11,22,99
Bạn chỉ có các chữ số 00~99.
Số nào xuất hiện nhiều lần thì xếp lên đầu, số nào ít lần thì xếp phía sau. Nếu số lần bằng nhau thì ưu tiên giá trị lớn.
Sau cùng, số nào chưa có trong dãy trên thì xếp vào phía sau, ưu tiền số có giá trị lớn.

Vậy, tôi sẽ nối các số 99,98,....,00 vào sau chuỗi INPUT đầu vào.
Sau đó tôi sẽ thực hiện đếm, xem số nào xuất hiện nhiều lần. Nếu số lần bằng nhau thì ưu tiên số có giá trị lớn.

Mã:
Sub test()
    Dim s2   As String
    s2 = ThisWorkbook.Sheets(1).Cells(1, 1).Value

    MsgBox main(s2)
End Sub
'INPUT: 00,33,44,33,33,11,22,99
'OUTPUT:33,99,44,22,11,00,98,97,...
Function main(ByVal s2 As String) As String
   
    Dim dic As Object
    Dim arr, brr, crr
    Dim i, sl As Long
    Dim kq  As String
    Dim skt As String
    Dim s  As String
   
   
   
   
   
    s = s2
    For i = 99 To 0 Step -1
        s = s & "," & Format(i, "00")
    Next i
    arr = Split(s, ",")
    Set dic = CreateObject("Scripting.dictionary")
   
    For i = LBound(arr) To UBound(arr) Step 1
        If arr(i) >= 0 And arr(i) < 100 Then
            arr(i) = Val(CStr(arr(i)))
            If dic.Exists(arr(i)) Then
                dic.Item(arr(i)) = dic.Item(arr(i)) + 1
            Else
                dic.Item(arr(i)) = 1
            End If
        End If
    Next i
    brr = dic.items
    crr = dic.keys
    For i = LBound(brr) To UBound(brr) Step 1
        sl = Application.WorksheetFunction.Large(brr, i + 1)
        kq = kq & "," & Format(crr(timso(crr, brr, sl, skt)), "00")
    Next i
   
   
    main = Right(kq, Len(kq) - 1)
   
   
 
End Function
Function timso(ByVal crr As Variant, ByVal brr As Variant, ByVal sl As Long, ByRef skt As String) As Long
    Dim i   As Long
    Dim temp As Long, temp2 As String
    Dim kq   As Long
   
    temp = -1
    For i = LBound(brr) To UBound(brr) Step 1
        If brr(i) = sl Then
            If temp < crr(i) Then
                temp2 = "@" & crr(i) & "@"
                If InStr(1, skt, temp2, vbTextCompare) = 0 Then
                    temp = crr(i)
                    kq = i
                End If
            End If
        End If
    Next i
    timso = kq
    skt = skt & "@" & crr(kq) & "@"

End Function
 
Kính gửi quý anh chị @Thiên Thanh
Quý anh chị có thể cung cấp file demo không. Chứ nhìn K2, E3 nhưng em không hiểu nó là gì ạ.
Em rất xin lỗi vì những đòi hỏi như này có thể làm phiền lòng anh chị, chắc là anh chị bận lắm phải không ạ.
 
Bạn thử:
Bạn cần đăng nhập để thấy hình ảnh

Mã:
Function noiso(ParamArray arr() As Variant) As String
    Dim r
    Dim r1  As Range
    
    Dim s   As String
    On Error GoTo thoat
    For Each r In arr
        If TypeOf r Is Range Then
            For Each r1 In r
                s = s & "," & r1.Value
            Next r1
            
        End If
        
    Next r
    s = Replace(s, ",,", ",", , , vbTextCompare)
    noiso = main(s)
thoat:

End Function


'INPUT: 00,33,44,33,33,11,22,99
'OUTPUT:33,99,44,22,11,00,98,97,...
Function main(ByVal s2 As String) As String
   
    Dim dic As Object
    Dim arr, brr, crr
    Dim i, sl As Long
    Dim kq  As String
    Dim skt As String
    Dim s  As String
   
   
   
   
   
    s = s2
    For i = 99 To 0 Step -1
        s = s & "," & Format(i, "00")
    Next i
    arr = Split(s, ",")
    Set dic = CreateObject("Scripting.dictionary")
   
    For i = LBound(arr) To UBound(arr) Step 1
        If arr(i) >= 0 And arr(i) < 100 Then
            arr(i) = Val(CStr(arr(i)))
            If dic.Exists(arr(i)) Then
                dic.Item(arr(i)) = dic.Item(arr(i)) + 1
            Else
                dic.Item(arr(i)) = 1
            End If
        End If
    Next i
    brr = dic.items
    crr = dic.keys
    For i = LBound(brr) To UBound(brr) Step 1
        sl = Application.WorksheetFunction.Large(brr, i + 1)
        kq = kq & "," & Format(crr(timso(crr, brr, sl, skt)), "00")
    Next i
   
   
    main = Right(kq, Len(kq) - 1)
   
   
 
End Function
Function timso(ByVal crr As Variant, ByVal brr As Variant, ByVal sl As Long, ByRef skt As String) As Long
    Dim i   As Long
    Dim temp As Long, temp2 As String
    Dim kq   As Long
   
    temp = -1
    For i = LBound(brr) To UBound(brr) Step 1
        If brr(i) = sl Then
            If temp < crr(i) Then
                temp2 = "@" & crr(i) & "@"
                If InStr(1, skt, temp2, vbTextCompare) = 0 Then
                    temp = crr(i)
                    kq = i
                End If
            End If
        End If
    Next i
    timso = kq
    skt = skt & "@" & crr(kq) & "@"

End Function
Tham khảo:


 

Thiên Thanh

Yêu THVBA
Cảm ơn bạn @vanthanhVBA đã nhiệt tình giúp đỡ
Bạn cho mình hỏi thêm là mình viết thủ tục gọi hàm như này nó báo lỗi là như nào vậy hở bạn?
Mã:
Sub test22222()
    Dim s2 As Range
    Set s2 = noiso(Range("g5", "g17", "C2:E7"))
MsgBox noiso(s2)
End Sub
 
D

Deleted member 208

Guest
Cảm ơn bạn @vanthanhVBA đã nhiệt tình giúp đỡ
Bạn cho mình hỏi thêm là mình viết thủ tục gọi hàm như này nó báo lỗi là như nào vậy hở bạn?
Mã:
Sub test22222()
    Dim s2 As Range
    Set s2 = noiso(Range("g5", "g17", "C2:E7"))
MsgBox noiso(s2)
End Sub
s2 là string. bạn khai báo là range nên vi phạm.
s2 đã được tính qua hàm noiso.
sao ở dưới msgbox lại tính lại noiso(s2) vậy bạn.
hàm noiso chỉ xử lý địa chỉ range nên chữ Range ở trong cụm từ này là không cần thiết viết vào Range("g5", "g17", "C2:E7") .
 

snow26

Yêu THVBA
Các bạn code hay quá. Code như thế này thì hàm chọn được vùng các ô liên tiếp và cả ô riêng rẽ nữa.
Mã:
noiso("A1:C5","B3:h7","L6","k5")
 
Top