Giúp tạo function vba để random kết quả từ danh sách cho sẵn (1 người xem)

[phanthanh157]

Hiện tại mình có 1 file danh sách lỗi sản phẩm, cũng như mã phân loại, mình muốn tạo một function(item) cho kết quả là một random của item đó trong danh sách.

 

[ndu96081631]

Hiện tại mình có 1 file danh sách lỗi sản phẩm, cũng như mã phân loại, mình muốn tạo một function(item) cho kết quả là một random của item đó trong danh sách.

Dùng hàm INDEX kết hợp RANDBETWEEN là được rồi:

=INDEX($B$2:$B$16,RANDBETWEEN(1,15))

 

[SA_DQ]

Bạn thao tác thử với cái ni:

Function RandomizeItem(iTem As Long, CSDL As Range) As String
Dim sRng As Range, Rng As Range
Dim Rws As Long, W As Long, Dm As Integer:     Dim MyAdd As String

Rws = CSDL.Rows.Count
Set Rng = CSDL(1).Resize(Rws)
ReDim Arr(1 To Rws, 1 To 1) As String
Set sRng = Rng.Find(iTem, , xlFormulas, xlWhole)
If sRng Is Nothing Then
    RandomizeItem = "Nothing"
Else
'   MyAdd = sRng.Address        '
    Set Rng = sRng.Resize(Rws)
    For Each CSDL In Rng
        If CSDL.Value = iTem Then
            W = W + 1:                          Arr(W, 1) = CSDL.Offset(, 1).Value
        End If
    Next CSDL
    Randomize:                                  Dm = (1 + W * Rnd()) \ 1
    RandomizeItem = Arr(Dm, 1)
End If
End Function

 

[phanthanh157]

Bạn thao tác thử với cái ni:

Function RandomizeItem(iTem As Long, CSDL As Range) As String
Dim sRng As Range, Rng As Range
Dim Rws As Long, W As Long, Dm As Integer:     Dim MyAdd As String

Rws = CSDL.Rows.Count
Set Rng = CSDL(1).Resize(Rws)
ReDim Arr(1 To Rws, 1 To 1) As String
Set sRng = Rng.Find(iTem, , xlFormulas, xlWhole)
If sRng Is Nothing Then
    RandomizeItem = "Nothing"
Else
'   MyAdd = sRng.Address        '
    Set Rng = sRng.Resize(Rws)
    For Each CSDL In Rng
        If CSDL.Value = iTem Then
            W = W + 1:                          Arr(W, 1) = CSDL.Offset(, 1).Value
        End If
    Next CSDL
    Randomize:                                  Dm = (1 + W * Rnd()) \ 1
    RandomizeItem = Arr(Dm, 1)
End If
End Function

Chào a, em đã thử, nhưng khi radom thì vẫn có radom trả về giá trị rỗng

 

[SA_DQ]

Chào a, em đã thử, nhưng khi radom thì vẫn có radom trả về giá trị rỗng

Bạn nên mô tả trường hợp 'rỗng' mà bạn đã gặp fải để cùng khắc fục & hoàn chỉnh.

Chắc là trị W cần bớt thêm 1 đơn vị.

 

[phanthanh157]

Bạn nên mô tả trường hợp 'rỗng' mà bạn đã gặp fải để cùng khắc fục & hoàn chỉnh.

Chắc là trị W cần bớt thêm 1 đơn vị.

Ý Mình khi random không cho kết quả tương ứng với item trong csdl mà đôi khi chỉ trả về kết quả trống

 

[phanthanh157]

Function RandomizeItem(iTem As Long, CSDL As Range) As String
Dim sRng As Range, Rng As Range
Dim Rws As Long, W As Long, Dm As Integer: Dim MyAdd As String
Dim coll As Collection

Rws = CSDL.Rows.Count
Set coll = New Collection
Set Rng = CSDL(1).Resize(Rws)
Set sRng = Rng.Find(iTem, , xlFormulas, xlWhole)
If sRng Is Nothing Then
RandomizeItem = "Nothing"
Else
' MyAdd = sRng.Address '
Set Rng = sRng.Resize(Rws)
For Each CSDL In Rng
If CSDL.value = iTem Then
coll.Add CSDL.Offset(, 1).value
End If
Next CSDL
Randomize: Dm = Int((coll.Count) * Rnd + 1)
RandomizeItem = coll(Dm)
End If
End Function
Mình có sửa lại code chạy thì dk nhưng không biết có đúng không

 

[Ba Tê]

Ý Mình khi random không cho kết quả tương ứng với item trong csdl mà đôi khi chỉ trả về kết quả trống

Public Function Gpe(ByVal Item As Range, ByVal Rng As Range) As Variant
Dim sArr(), tArr(), I As Long, K As Long, R As Long
sArr = Rng.Value
R = UBound(sArr)
ReDim tArr(1 To R, 1 To 2)
For I = 1 To R
    If sArr(I, 1) = Item.Value Then
        K = K + 1
        tArr(K, 1) = sArr(I, 1)
        tArr(K, 2) = sArr(I, 2)
    End If
Next I
Randomize
    R = Int(Rnd * K) + 1
Gpe = tArr(R, 2)
End Function

 

[Phuocam]

đôi khi chỉ trả về kết quả trống

Trường hợp csdl có dòng rỗng, bạn thử công thức này:

=INDEX(B:B,LARGE(INDEX((B2:B16<>"")*ROW(B2:B16),0),RANDBETWEEN(1,COUNTA(B2:B16))))

 

[phanthanh157]

Trường hợp csdl có dòng rỗng, bạn thử công thức này:

=INDEX(B:B,LARGE(INDEX((B2:B16<>"")*ROW(B2:B16),0),RANDBETWEEN(1,COUNTA(B2:B16))))

Ok bạn, tại mình đang dùng hàm này sử dụng cho code vba khác trong file chứ ko dùng trực tiếp trên sheet

 

[VetMini]

Bạn thao tác thử với cái ni:

Function RandomizeItem(iTem As Long, CSDL As Range) As String
Dim sRng As Range, Rng As Range
Dim Rws As Long, W As Long, Dm As Integer:     Dim MyAdd As String

Rws = CSDL.Rows.Count
Set Rng = CSDL(1).Resize(Rws)
ReDim Arr(1 To Rws, 1 To 1) As String
Set sRng = Rng.Find(iTem, , xlFormulas, xlWhole)
If sRng Is Nothing Then
    RandomizeItem = "Nothing"
Else
'   MyAdd = sRng.Address        '
    Set Rng = sRng.Resize(Rws)
    For Each CSDL In Rng
        If CSDL.Value = iTem Then
            W = W + 1:                          Arr(W, 1) = CSDL.Offset(, 1).Value
        End If
    Next CSDL
    Randomize:                                  Dm = (1 + W * Rnd()) \ 1
    RandomizeItem = Arr(Dm, 1)
End If
End Function

1. Hàm Randomize chỉ nên chạy 1 lần

Function RandomPick(...) ' từ RandomizeItem ở đây dùng không đúng tiếng Anh lắm, nếu muốn thì dùng RandomItem
Static RNDMIZED As Boolean
If Not RNDMIZED Then
Randomize
RNDMIZED = True
End If
... code ở đây

2. Giải thuật tìm là

(i) Dùng hàm CountIf để đếm số lần xuất hiện của mã

SL = Application.CountIf(...)
If SL < 1 Then
... không có, xử lý gì đó
Exit Function
End If
... Dùng giải thuật theo (ii)

(ii) Dùng hàm Rnd để tìm một số random giữa 1 và SL
Dùng Find để tìm lần thứ 1
Dùng vòng lăp 2 đến số n và áp dụng hàm FindNext

... Dùng Find ở đây
For i = 2 To Int (SL * Rnd + 1)
... Dùng FindNext ở đây
Next i

 

[SA_DQ]

Hình như chỉ xài được FindNext trong Sub thôi; Trong hàm (Function) thì chỉ hiện kết quả được trên CS Immediate

 

[VetMini]

Hình như chỉ xài được FindNext trong Sub thôi; Trong hàm (Function) thì chỉ hiện kết quả được trên CS Immediate

Xin lỗi, tôi nhầm. Hàm Find cache vị trí con trỏ dò với lệnh Find/Replace trong worksheet cho nên khi dùng trong worksheet thì FindNext bị tắt.
Dùng Find với tham số After