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
Cảm ơn
Bạn cần đăng nhập để thấy hình ảnh
VIP
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
VIP
VIP
VIP
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
Sub test22222()
Dim s2 As Range
Set s2 = noiso(Range("g5", "g17", "C2:E7"))
MsgBox noiso(s2)
End Sub
VIP
Sub test22222()
Dim s2 As String
s2 = noiso("g5", "g17", "C2:E7")
MsgBox s2
End Sub
VIP
s2 là string. bạn khai báo là range nên vi phạm.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
Bạn phải khai báo là:
s2 là string.
Cụ thể code như sau:
Mã:Sub test22222() Dim s2 As String s2 = noiso("g5", "g17", "C2:E7") MsgBox s2 End Sub