Điền giá trị ngẫu nhiên với số lượng cho trước

Liên hệ QC

sangucu

Thành viên mới
Tham gia
29/3/19
Bài viết
6
Được thích
0
Em kính chào các bác. Em có bài toán sau nhờ các bác giúp đỡ với a.

Em có 11 con số tương ứng với số lần xuất hiện ngẫu nhiên vào một vùng có 10 hàng 10 cột.

Rất mong các bác viết code VBA giúp em ạ.

Em xin chân thành cảm ơn.!

(file đính kèm của em dưới đây ạ.!).
 

File đính kèm

  • chọn ngẫu nhiên.xlsb.xlsx
    9 KB · Đọc: 46
Em kính chào các bác. Em có bài toán sau nhờ các bác giúp đỡ với a.

Em có 11 con số tương ứng với số lần xuất hiện ngẫu nhiên vào một vùng có 10 hàng 10 cột.

Rất mong các bác viết code VBA giúp em ạ.

Em xin chân thành cảm ơn.!

(file đính kèm của em dưới đây ạ.!).
Code xong rồi, sửa tiêu đề "Điền giá trị ngẫu nhiên với số lượng cho trước" xong mình gửi code lên
 
Upvote 0
chờ mãi mới có " cao nhân " vào để xem cái code
 
Upvote 0
Em kính chào các bác. Em có bài toán sau nhờ các bác giúp đỡ với a.

Em có 11 con số tương ứng với số lần xuất hiện ngẫu nhiên vào một vùng có 10 hàng 10 cột.

Rất mong các bác viết code VBA giúp em ạ.

Em xin chân thành cảm ơn.!

(file đính kèm của em dưới đây ạ.!).
Bạn muốn có tất cả các đáp án hay là 1?
 
Upvote 0
A cái này là đánh Keno đây mà.
Nhưng mà cỡ mình là nhất lưu rồi, gọi cao nhân chưa xứng, hỏng thèm làm.
 
Upvote 0
Code xong rồi, sửa tiêu đề "Điền giá trị ngẫu nhiên với số lượng cho trước" xong mình gửi code lên
Anh oi chieu em log acc em bang dong bo email. Ko hieu sao gio ko log dc nua.
Anh up len giup em di a
Bài đã được tự động gộp:

Bạn muốn có tất cả các đáp án hay là 1?
Anh oi em muon tao nut click de moi lan kick chuot se cho mot phuong an ngau nhien khac nhau a
 
Upvote 0
Thấy dân đói bài tính dụ hả.
 
Upvote 0
Thứ nhất là sửa tiêu đề như bài #2 đề nghị.
Thứ hai là đợi bao giờ gõ được tiếng có dấu rồi nói chuyện tiếp.
 
Upvote 0
A cái này là đánh Keno đây mà.
Nhưng mà cỡ mình là nhất lưu rồi, gọi cao nhân chưa xứng, hỏng thèm làm.
Nhf
A cái này là đánh Keno đây mà.
Nhưng mà cỡ mình là nhất lưu rồi, gọi cao nhân chưa xứng, hỏng thèm làm.
Nhờ Bác xuất chiêu cho Em thử thời vận, nếu thắng 50-50 được không Bác?
Em ứng trước 100k, nếu thua em vẫn mời Bác 1 café đá nha!
Quê em café đá giá 10k
Chúc Bác cuối tuần vui vẻ
 
Upvote 0
Thứ nhất là sửa tiêu đề như bài #2 đề nghị.
Thứ hai là đợi bao giờ gõ được tiếng có dấu rồi nói chuyện tiếp.
Híc,,, em log lại bằng máy tính của em thì sửa được tiêu đề rồi và viết có dấu được rồi đây ạ? Bác ra tay giúp em vì đam mê học hỏi thôi chứ ko ham hố hay dụ dỗ gì đâu ạ.
 
Upvote 0
Em kính chào các bác. Em có bài toán sau nhờ các bác giúp đỡ với a.

Em có 11 con số tương ứng với số lần xuất hiện ngẫu nhiên vào một vùng có 10 hàng 10 cột.

Rất mong các bác viết code VBA giúp em ạ.

Em xin chân thành cảm ơn.!

(file đính kèm của em dưới đây ạ.!).
Viết đại code thế này:
Mã:
Sub Test()
  Dim arr
  Dim idx       As Long
  Dim lPos      As Long
  Dim lNewTop   As Long
  Dim lR        As Long
  Dim lC        As Long
  arr = Sheet1.Range("A2:B12").Value
  ReDim aDes(1 To 10, 1 To 10)
  lNewTop = 11
  Randomize
  Do
    lPos = Int(Rnd() * lNewTop) + 1
    idx = idx + 1
    lR = Int((idx - 1) / 10) + 1
    lC = ((idx - 1) Mod 10) + 1
    aDes(lR, lC) = arr(lPos, 1)
    If arr(lPos, 2) > 0 Then arr(lPos, 2) = arr(lPos, 2) - 1
    If arr(lPos, 2) <= 0 Then
      arr(lPos, 1) = arr(lNewTop, 1)
      arr(lPos, 2) = arr(lNewTop, 2)
      lNewTop = lNewTop - 1
    End If
  Loop Until lNewTop = 0
  Range("D2:M11").Value = aDes
End Sub
Không biết có chỗ nào sai không nữa???!!!
Bạn kiểm tra xem!
 

File đính kèm

  • chọn ngẫu nhiên.xlsm
    19.2 KB · Đọc: 40
Upvote 0
. .
Mã:
Sub t()
Const SOLUONG = 100
Const SODONG = 10
Const SOCOT = 10
Dim b(1 To SODONG, 1 To SOCOT) ' mang ket qua
a = Range("a2").Resize(11, 2).Value ' doc du lieu
For i1 = 1 To 11
  a1 = Val(Split(a(i1, 1), " ")(1)) ' so can lay
  a2 = Val(Split(a(i1, 2), " ")(0)) ' so luong can lay
  tongSoLan = tongSoLan + a2
  If tongSoLan > SOLUONG Then
    MsgBox "nhieu qua, vuot so luong toi da"
    Exit For
  End If
  For i2 = 1 To a2
    p = Application.RandBetween(1, SOLUONG) ' vi tri so
    ' nhet vao mang b
    Do While True
      p1 = (p - 1) \ SOCOT + 1 ' dong
      p2 = p - (p1 - 1) * SOCOT ' cot
      If CStr(b(p1, p2)) = "" Then ' vi tri con trong
        b(p1, p2) = (a1)
        Exit Do
      End If
      p = IIf(p >= SOLUONG, 1, p + 1) ' thu vi tri ke tiep
    Loop
  Next i2
Next i1
Range("D2").Resize(SODONG, SOCOT).Value = b
End Sub
 
Upvote 0
Em kính chào các bác. Em có bài toán sau nhờ các bác giúp đỡ với a.

Em có 11 con số tương ứng với số lần xuất hiện ngẫu nhiên vào một vùng có 10 hàng 10 cột.

Rất mong các bác viết code VBA giúp em ạ.

Em xin chân thành cảm ơn.!

(file đính kèm của em dưới đây ạ.!).
Một cách dùng Power query, chuột phải bấm refresh!
 

File đính kèm

  • chọn ngẫu nhiên.xlsx
    20.8 KB · Đọc: 31
Upvote 0
Anh oi chieu em log acc em bang dong bo email. Ko hieu sao gio ko log dc nua.
Anh up len giup em di a
Như đã hứa, tuy code cùi nhưng cũng là một cách bạn tham khảo:
Mã:
Option Explicit

Sub Random()
Dim I As Long, iMax As Long, iMin As Long, a As Long, b As Long, c As Long
Dim R As Long, Rng As Range, Cll As Range, RngF As Range
Application.ScreenUpdating = False
iMax = Application.Max(Range("A2:A12"))
iMin = Application.Min(Range("A2:A12"))
Set Rng = [D2:M11]
Rng.ClearContents
For Each Cll In Rng
    c = 0
    Do
    a = Application.RandBetween(iMin, iMax)
    Set RngF = Range("A2:A12").Find(a, , , xlWhole)
        If Not RngF Is Nothing Then
            b = WorksheetFunction.CountIf(Rng, a)
            c = RngF.Offset(, 1).Value
        End If
    Loop Until Not RngF Is Nothing And b <= c - 1
    Cll = a
Next
Application.ScreenUpdating = True
End Sub
 

File đính kèm

  • chọn ngẫu nhiên.xlsm
    18.7 KB · Đọc: 31
Upvote 0
Hãy thử với dữ liệu:
Số 6090
Số 581
Số 551
Số 521
Số 491
Số 451
Số 411
Số 371
Số 331
Số 301
Số 01

Nếu có số khác "Số 60" có thể xuất hiện ngẫu nhiên trong dòng 10 là ngon lành.
 
Upvote 0
Như đã hứa, tuy code cùi nhưng cũng là một cách bạn tham khảo:
Mã:
Option Explicit

Sub Random()
Dim I As Long, iMax As Long, iMin As Long, a As Long, b As Long, c As Long
Dim R As Long, Rng As Range, Cll As Range, RngF As Range
Application.ScreenUpdating = False
iMax = Application.Max(Range("A2:A12"))
iMin = Application.Min(Range("A2:A12"))
Set Rng = [D2:M11]
Rng.ClearContents
For Each Cll In Rng
    c = 0
    Do
    a = Application.RandBetween(iMin, iMax)
    Set RngF = Range("A2:A12").Find(a, , , xlWhole)
        If Not RngF Is Nothing Then
            b = WorksheetFunction.CountIf(Rng, a)
            c = RngF.Offset(, 1).Value
        End If
    Loop Until Not RngF Is Nothing And b <= c - 1
    Cll = a
Next
Application.ScreenUpdating = True
End Sub

Thank you very much.!
Happy weekend to you...
Bài đã được tự động gộp:

Viết đại code thế này:
Mã:
Sub Test()
  Dim arr
  Dim idx       As Long
  Dim lPos      As Long
  Dim lNewTop   As Long
  Dim lR        As Long
  Dim lC        As Long
  arr = Sheet1.Range("A2:B12").Value
  ReDim aDes(1 To 10, 1 To 10)
  lNewTop = 11
  Randomize
  Do
    lPos = Int(Rnd() * lNewTop) + 1
    idx = idx + 1
    lR = Int((idx - 1) / 10) + 1
    lC = ((idx - 1) Mod 10) + 1
    aDes(lR, lC) = arr(lPos, 1)
    If arr(lPos, 2) > 0 Then arr(lPos, 2) = arr(lPos, 2) - 1
    If arr(lPos, 2) <= 0 Then
      arr(lPos, 1) = arr(lNewTop, 1)
      arr(lPos, 2) = arr(lNewTop, 2)
      lNewTop = lNewTop - 1
    End If
  Loop Until lNewTop = 0
  Range("D2:M11").Value = aDes
End Sub
Không biết có chỗ nào sai không nữa???!!!
Bạn kiểm tra xem!

Em cam on bac aj.
 
Upvote 0
Như đã hứa, tuy code cùi nhưng cũng là một cách bạn tham khảo:
Mã:
Option Explicit

Sub Random()
Dim I As Long, iMax As Long, iMin As Long, a As Long, b As Long, c As Long
Dim R As Long, Rng As Range, Cll As Range, RngF As Range
Application.ScreenUpdating = False
iMax = Application.Max(Range("A2:A12"))
iMin = Application.Min(Range("A2:A12"))
Set Rng = [D2:M11]
Rng.ClearContents
For Each Cll In Rng
    c = 0
    Do
    a = Application.RandBetween(iMin, iMax)
    Set RngF = Range("A2:A12").Find(a, , , xlWhole)
        If Not RngF Is Nothing Then
            b = WorksheetFunction.CountIf(Rng, a)
            c = RngF.Offset(, 1).Value
        End If
    Loop Until Not RngF Is Nothing And b <= c - 1
    Cll = a
Next
Application.ScreenUpdating = True
End Sub
Bác ơi, tỷ lệ số 0 xuất hiện ở hàng dưới cùng cao bất thường. Bác check lại code giúp em với.
Bài đã được tự động gộp:

Viết đại code thế này:
Mã:
Sub Test()
  Dim arr
  Dim idx       As Long
  Dim lPos      As Long
  Dim lNewTop   As Long
  Dim lR        As Long
  Dim lC        As Long
  arr = Sheet1.Range("A2:B12").Value
  ReDim aDes(1 To 10, 1 To 10)
  lNewTop = 11
  Randomize
  Do
    lPos = Int(Rnd() * lNewTop) + 1
    idx = idx + 1
    lR = Int((idx - 1) / 10) + 1
    lC = ((idx - 1) Mod 10) + 1
    aDes(lR, lC) = arr(lPos, 1)
    If arr(lPos, 2) > 0 Then arr(lPos, 2) = arr(lPos, 2) - 1
    If arr(lPos, 2) <= 0 Then
      arr(lPos, 1) = arr(lNewTop, 1)
      arr(lPos, 2) = arr(lNewTop, 2)
      lNewTop = lNewTop - 1
    End If
  Loop Until lNewTop = 0
  Range("D2:M11").Value = aDes
End Sub
Không biết có chỗ nào sai không nữa???!!!
Bạn kiểm tra xem!
Code của bác cũng bị hiện tượng số 0 xuất hiện ở hàng dưới cùng quá cao ạ
 
Upvote 0
Bác ơi, tỷ lệ số 0 xuất hiện ở hàng dưới cùng cao bất thường. Bác check lại code giúp em với.
Chắc do số 0 nhiều quá nên mỗi lần random nó ra số khác nhau, lần này ra số 0 rồi thì tỷ lệ lần sau ra số 0 ít đi, do đó cuối cùng khi các số kia đủ rồi thì lòi ra số 0 nhiều nhất. bạn thử cho số liệu như này sẽ thấy rất là "ngẫu nhiên"
6010
589
559
529
499
459
419
379
339
309
09
 
Upvote 0
@sangucu
Thử code abc trong file đính kèm
Mã:
Option Explicit

Sub abc()
Dim Nguon
Dim Mang
Dim Kq
Dim dau, slD
Dim i, j, k, x, z, t
Nguon = Sheet1.Range("A2:B12")
slD = UBound(Nguon)
ReDim Mang(1 To 100)
ReDim Kq(1 To 10, 1 To 10)
Randomize
dau = Int(Rnd() * (slD - 1)) + 1
For i = dau To dau + slD - 1
    k = ((i - 1) Mod slD) + 1
    For j = 1 To Nguon(k, 2)
        t = t + 1
        Mang(t) = Nguon(k, 1)
    Next j
Next i
For z = 100 To 1 Step -1
    k = Int(Rnd() * (z - 1)) + 1
    i = Int((z - 1) / 10) + 1
    j = ((z - 1) Mod 10) + 1
    Kq(i, j) = Mang(k)
    Mang(k) = Mang(z)
Next z
With Sheet1
    .Range("D2").Resize(10, 10).ClearContents
    .Range("D2").Resize(10, 10) = Kq
    .Range("D2").Resize(10, 10).Borders.LineStyle = 1
End With
End Sub
 

File đính kèm

  • chọn ngẫu nhiên (1).xlsm
    24.6 KB · Đọc: 25
Upvote 0
Web KT
Back
Top Bottom