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

Sangucu

Yêu THVBA
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.

Tao nut Click de moi lan Click se cho ra ket qua ngau nhien khac nhau.

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

Em xin chân thành cảm ơn.!
Bạn cần đăng nhập để thấy hình ảnh
 
Sửa lần cuối:

phuonghong1997

Yêu THVBA như điếu đổ
Không có file demo à bạn. Code giờ lại phải ngồi tự tạo form, ngại lắm. Bạn rút kinh nghiệm nha.
 
1. Chuẩn bị: Tạo ra file có 2 sheet. Một sheet để ghi kết quả. Một sheet để nháp. Tên sheet ghi tùy ý. Sheet 1 là nơi tôi ghi kết quả. Sheet 2 là nơi tôi nháp.
Mình nghĩ nếu thao tác trên mảng thì nhanh hơn, nhưng thiếu trực quan với người mới học. Bản thân mình code cũng còn yếu. Vì vậy xin phép đi theo hướng này.
2. Thiết kế form:
[Sheet1]

Bạn cần đăng nhập để thấy hình ảnh

Trên ô C3 tôi dùng công thức SUM kiểm tra đầu vào có phải là 100 số hay không.
Nếu không phải thì thoát.

Tôi nghĩ code sẽ chặt chẽ hơn nếu kiểm tra xem có số nào có số lần là 0 hay không. Tuy nhiên việc này rườm rà mất thời gian, nên tôi mặc định số lần luôn là số nguyên dương.

3. Thuật toán:
Tôi đơn giản ghi các số theo số lần xuất hiện lên cột A của sheet 2.
[Sheet2]
Bạn cần đăng nhập để thấy hình ảnh

Cột B là nơi tôi tạo ra các số ngẫu nhiên.
Cột C là nơi tôi xếp thứ hạng từ cao xuống thấp dựa vào dãy số ngẫu nhiên trên cột B.
Dựa vào dữ liệu cột C tôi sẽ ghi kết quả số tương ứng ở cột A vào bảng kết quả.
Ví dụ: Dòng 19.
Số 0 có thứ hạng 73. Tôi mong mốn xếp số 0 này vào hàng 7, cột 3 trên bảng kết quả.
Kết quả:
Bạn cần đăng nhập để thấy hình ảnh

Để kiểm tra tính ngẫu nhiên, tôi chạy lại một lần nữa:
Bạn cần đăng nhập để thấy hình ảnh


4. Code:
Mã:
Sub tuhocvba()
    Dim i   As Long, j As Long, cnt As Long
    Dim n   As Long
    Dim rend    As Long
    Dim arr
    Dim rng As Range
    Dim r As Long, r1 As Long, c As Long
    
    
    Dim myDic As Object
    On Error Resume Next
    
    With ThisWorkbook.Sheets(1)
        n = .Cells(1, 3) 'C1
        rend = .Cells(.Rows.Count, 1).End(3).Row
        arr = .Range(.Cells(2, 1), .Cells(rend, 2)).Value
    End With
    On Error GoTo 0
    If n <> 100 Then
        MsgBox "Kiem tra gia tri o C1"
        Exit Sub 'khong phai la 100 thi thoat
    End If
    
    If rend < 2 Then
        MsgBox "Khong co du lieu tren cot A"
        Exit Sub
    End If
    
    Set myDic = CreateObject("Scripting.Dictionary")
    
    For i = LBound(arr, 1) To UBound(arr, 1) Step 1
        If Not myDic.Exists(arr(i, 1)) Then
            myDic.Add arr(i, 1), arr(i, 2)
        Else
            myDic.Item(arr(i, 1)) = myDic.Item(arr(i, 1)) + arr(i, 2)
        End If
    Next i
    'Xep ngau nhien
    arr = myDic.Keys
    cnt = 0
    On Error GoTo tiep
    With ThisWorkbook.Sheets(2)
        For i = LBound(arr) To UBound(arr) Step 1
            For j = 1 To myDic.Item(arr(i)) Step 1
                cnt = cnt + 1
                    .Cells(cnt, 1) = arr(i)
            Next j
tiep:
        Next i
    On Error GoTo 0
        If cnt = 0 Then Exit Sub
        Call Randomize 'Reset ngau nhien
        For i = 1 To cnt Step 1
            .Cells(i, 2) = Rnd
        Next i
        Set rng = .Range(.Cells(1, 2), .Cells(cnt, 2))
        For i = 1 To rng.Rows.Count
            .Cells(i, 3) = WorksheetFunction.Rank(.Cells(i, 2), rng)
        Next i
        arr = .Range(.Cells(1, 1), .Cells(cnt, 3)).Value
    End With
    'Ghi ket qua:
    With ThisWorkbook.Sheets(1)
        For i = LBound(arr, 1) To UBound(arr, 1) Step 1
            n = arr(i, 3)
            c = n Mod 10
            If c = 0 Then
                r1 = n / 10
                If r1 = 0 Then r1 = 1
            Else
                r1 = Int(n / 10) + 1
            End If
            
            r = r1 + 1
            If c = 0 Then
                c = 13
            Else
                c = c + 3
            End If
            .Cells(r, c) = arr(i, 1)
        Next i
    End With
End Sub
Do các yếu tố đầu vào bạn cho là cố định, chả hạn luôn là 100 số. Vì vậy tôi thấy không cần phải Clear sheet 2. Mỗi lần chạy cứ thế ghi đè lên phần nháp cũ.
 

tuhocvba

Administrator
Thành viên BQT
Tiếc là chủ topic đã không đưa file demo ngay từ đầu, vì vậy đã không nhận được trợ giúp sớm hơn.
Bài viết ở #3 là vô cùng dễ hiểu, dễ đọc.
 
Top