Lấy ra random một danh sách có điều kiện.

[Romeo8x]

Em có file exel ở dưới, ở Sheet2 em có 2 Col liên quan là animalName và animalType.
Ở Sheet1 em có 1 pic hình con bò. Em muốn Asign as Macro pic này để khi click vào thì sẽ lấy random 10 animalName trong Sheet2 với điều kiện là animalType = "Bull" (chỉ lấy những tên những con có Type là Bull thì mới lấy Name nó sang).
Và mỗi lần click thì sẽ lấy random lại, tên các con thì có thể vẫn thế nhưng thứ tự thì đổi ngược miễn sao không giống hệt ban đầu là được.

 

[SA_DQ]

Do mình không xem được file của bạn, Mình giả lập cái khác:

Option Explicit:                 Dim SoCu As Long
Private Sub Worksheet_Change(ByVal Target As Range)
 If Not Intersect(Target, [d1]) Is Nothing Then
   Dim Sh As Worksheet, Rng As Range, sRng As Range, mRng As Range
   Dim MyAdd As String, Tg As Integer, StrC As String
   
   Set Sh = Sheet2:           Set Rng = Sh.Range(Sh.[B1], Sh.[B65500].End(xlUp))
   Set sRng = Rng.Find(Target.Value, , xlFormulas, xlWhole)
   If Not sRng Is Nothing Then
      MyAdd = sRng.Address
      Do
         Tg = Tg + 1
         StrC = StrC & Right("00" & CStr(sRng.Row), 3)
         Set sRng = Rng.FindNext(sRng)
      Loop While Not sRng Is Nothing And sRng.Address <> MyAdd
   End If
   [a1].Value = Tg
   Randomize:                 Tg = Int(1 + (Tg - 3) * Rnd)
   [A2].Value = Tg
   MyAdd = (Mid(StrC, 1 + 3 * Tg, 3))
   [B1].Value = MyAdd
   If MyAdd <> SoCu Then
      [C1].Value = Sh.Cells(MyAdd, 1).Value
      SoCu = MyAdd
   Else
      [C1].Value = "GPE"
   End If
 End If
End Sub

 

[Romeo8x]

Cảm ơn anh, code của anh khá dễ hiểu. Tuy nhiên em muốn hỏi thêm là nếu em muốn lấy 10 tên chứ không phải 1 tên như file anh làm gửi lên thì code ntn?

 

[SA_DQ]

Chỉnh sửa cho bạn đây, xem thêm trong file

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
 If Not Intersect(Target, [d2]) Is Nothing Then
   Dim Sh As Worksheet, Rng As Range, sRng As Range
   Dim MyAdd As String, Tg As Integer, StrC As String, VTr As Byte
   
   Set Sh = Sheet2:           Set Rng = Sh.Range(Sh.[B1], Sh.[B65500].End(xlUp))
   Columns("B:B").ClearContents
   Set sRng = Rng.Find(Target.Value, , xlFormulas, xlWhole)
   If Not sRng Is Nothing Then
      MyAdd = sRng.Address
      Do
         Tg = Tg + 1
         If Tg Mod 2 = 0 Then
            StrC = StrC & Right("00" & CStr(sRng.Row), 3)
         Else
            StrC = Right("00" & CStr(sRng.Row), 3) & StrC
         End If
         If Tg > 4 Then
            Randomize:           VTr = Int(Tg - 4 * Rnd)
            StrC = Mid(StrC, 3 * VTr + 1) & Left(StrC, 3 * VTr)
         End If
         Set sRng = Rng.FindNext(sRng)
      Loop While Not sRng Is Nothing And sRng.Address <> MyAdd
   End If:                       [B1] = "Results"
   For VTr = 0 To 9
      With [B65500].End(xlUp).Offset(1)
         .Value = Sh.Cells(Mid(StrC, 3 * VTr + 1, 3), 1)
      End With
   Next VTr
 End If
End Sub

 

[ndu96081631]

Em có file exel ở dưới, ở Sheet2 em có 2 Col liên quan là animalName và animalType.
Ở Sheet1 em có 1 pic hình con bò. Em muốn Asign as Macro pic này để khi click vào thì sẽ lấy random 10 animalName trong Sheet2 với điều kiện là animalType = "Bull" (chỉ lấy những tên những con có Type là Bull thì mới lấy Name nó sang).
Và mỗi lần click thì sẽ lấy random lại, tên các con thì có thể vẫn thế nhưng thứ tự thì đổi ngược miễn sao không giống hệt ban đầu là được.

Tặng bạn 2 hàm này xài chơi:

Function UniqueList(SrcRng As Range)
  Dim Clls As Range
  With CreateObject("Scripting.Dictionary")
    For Each Clls In SrcRng
      If Clls <> "" And Not .Exists(Clls.Value) Then .Add Clls.Value, ""
    Next Clls
    UniqueList = WorksheetFunction.Transpose(.Keys)
  End With
End Function

Function RandListIf(SrcRng As Range, Cond As String, DesRng As Range, Amount As Long)
  Dim i As Long, j As Long
  Application.Volatile
  j = WorksheetFunction.CountIf(SrcRng, Cond)
  With CreateObject("Scripting.Dictionary")
    Do
      Randomize
      i = Int(Rnd() * SrcRng.Count)
      If DesRng(i) <> "" And SrcRng(i) = Cond And Not .Exists(DesRng(i).Value) Then
        .Add DesRng(i).Value, "": Amount = Amount - 1
      End If
    Loop Until Amount = 0 Or .Count = j
    RandListIf = WorksheetFunction.Transpose(.Keys)
  End With
End Function

-----------------
- Vẽ 1 ComboBox (Đặt tên là CBB) rồi dùng sự kiện Worksheet_Activate để nạp list cho ComboBox này (ComboBox có LinkedCell = D1)
- ComboBox này dùng để thay đổi AnimalType

Private Sub Worksheet_Activate()
  With Sheet1.Range(Sheet1.[C2], Sheet1.[C65536].End(xlUp))
    CBB.List() = UniqueList(.Cells)
  End With
End Sub

Quét chọn A2:A11 và gõ vào công thức mảng:

=RandListIf(Sheet1!$C$2:$C$38,$D$1,Sheet1!$B$2:$B$38,10)

- Muốn thay đổi list chỉ cần bấm F9
(Tôi gữi luôn 2 dạng file: xls và xlsm)
-------------------
Tham khảo thêm thuật toán tạo dảy số ngẫu nhiên không trùng tại đây:
http://www.giaiphapexcel.com/forum/showthread.php?t=27286
-------------------
Code của sư phụ HYen17 có 1 lổi chết người, đó là: TÊN không đủ số lượng 10 sẽ... ngoài ra nó chưa lọc được giá trị duy nhất (nếu có dữ liệu trùng)