Đếm số tổ hợp theo điều kiện và in ra Danh sách,

Liên hệ QC
Tôi tuân thủ nội quy khi đăng bài
Có
D

duongde84

Thành viên mới
Tham gia
9/4/11
Bài viết
20
Được thích
4
Chào Anh/Chị,

Em có một bài toán nhờ Anh/Chị xử lý giúp ạ. Em có 4 Danh sách các Cổ đông, phần trăm cổ phần tương ứng trong 4 năm từ 2018 đến 2022. Vấn đề của em là em muốn chọn ngẫu nhiên 25% số cổ đông của từng năm (số nguyên, làm tròn xuống) với điệu kiện là các Cổ đông chọn ngẫu nhiên của năm 2018 đều có mặt trong danh sách các Cổ đông chọn ngẫu nhiên của năm 2019. Tương tự như vậy, 25% Cổ đông chọn ngẫu nhiên của năm 2019 đều có mặt trong danh sách 25% Cổ đông chọn ngẫu nhiên của năm 2020, and so on ...
Anh/Chị chỉ giúp em dùng hàm nào để đếm được số lượng cách chọn với điều kiện như trên và có cách nào để in ra các bộ danh sách đó không.

Cảm ơn Anh/Chị nhiều, :):):)
 

File đính kèm

  • Danh sach CĐ 20182022.xlsx
    14.1 KB · Đọc: 10
Sắp xếp theo thời gian sắp xếp theo bầu chọn
duongde84 đã viết:
Chào Anh/Chị,

Em có một bài toán nhờ Anh/Chị xử lý giúp ạ. Em có 4 Danh sách các Cổ đông, phần trăm cổ phần tương ứng trong 4 năm từ 2018 đến 2022. Vấn đề của em là em muốn chọn ngẫu nhiên 25% số cổ đông của từng năm (số nguyên, làm tròn xuống) với điệu kiện là các Cổ đông chọn ngẫu nhiên của năm 2018 đều có mặt trong danh sách các Cổ đông chọn ngẫu nhiên của năm 2019. Tương tự như vậy, 25% Cổ đông chọn ngẫu nhiên của năm 2019 đều có mặt trong danh sách 25% Cổ đông chọn ngẫu nhiên của năm 2020, and so on ...
Anh/Chị chỉ giúp em dùng hàm nào để đếm được số lượng cách chọn với điều kiện như trên và có cách nào để in ra các bộ danh sách đó không.

Cảm ơn Anh/Chị nhiều, :):):)
Nhấp chuột vào đây để mở rộng...
Tạo sheet KQ lưu dữ liệu lọc. Chạy code XYZ
Mã: 
Option Explicit
Sub XYZ()
  Dim arr(), sR(), aRand, aRes(), tRes, res(), dic As Object
  Dim i&, r&, j&, c&
  Const N& = 4 '4 nam
  ReDim arr(1 To N):  ReDim sR(1 To N, 0 To 1): ReDim res(1 To N)
  Set dic = CreateObject("scripting.dictionary")
 
  With Sheets("Shareholder#")
    For j = 1 To N
      arr(j) = .Range(.Cells(3, j * 4 - 2), .Cells(3, j * 4 - 1).End(xlDown)).Value
      sR(j, 0) = UBound(arr(j))
      r = Int(sR(j, 0) / 4)
      ReDim aRow(1 To r)
      ReDim aRes(1 To r, 1 To 3)
      res(j) = aRes
    Next j
  End With
'Loai cac Co Dong khong co o nam sau
  For j = N - 1 To 1 Step -1
    Call CoDong(dic, arr, sR, j)
  Next j
'Chon cac gia tri ngau nhien
  Randomize
  For j = 1 To N
    aRand = UniqueRand(sR(j, 0))
    For r = 1 To UBound(aRand)
      If arr(j)(aRand(r), 1) <> Empty Then
        For c = j To N
          sR(c, 1) = sR(c, 1) + 1
          res(c)(sR(c, 1), 2) = arr(c)(aRand(r), 1)
          res(c)(sR(c, 1), 3) = arr(c)(aRand(r), 2)
          arr(c)(aRand(r), 1) = Empty
        Next c
        If sR(j, 1) = UBound(res(j)) Then Exit For
      End If
    Next r
  Next j
'Xep thu tu ngau nhien
  tRes = res
  For j = 1 To N
    aRand = UniqueRand(UBound(res(j)))
    For r = 1 To UBound(aRand)
      res(j)(r, 1) = r
      res(j)(r, 2) = tRes(j)(aRand(r), 2)
      res(j)(r, 3) = tRes(j)(aRand(r), 3)
    Next r
  Next j
'Gan ket qua
  With Sheets("KQ")
    For j = 1 To N
      .Cells(3, j * 4 - 3).Resize(UBound(res(j)), 3) = res(j)
    Next j
  End With
End Sub

Function UniqueRand(ByVal N As Long) As Variant 'Mang Day so ngau nhien 1 to N
  Dim arr&(), i&, RndNum&, tmp&
  ReDim arr&(1 To N)
  'Randomize
  For i = 1 To N
    RndNum = Int(N * Rnd() + 1)
    If arr(RndNum) = 0 Then tmp = RndNum Else tmp = arr(RndNum)
    If arr(N) = 0 Then arr(RndNum) = N Else arr(RndNum) = arr(N)
    arr(N) = tmp
    N = N - 1
  Next i
  UniqueRand = arr
End Function

Private Sub CoDong(dic, arr, sR, j)  'Loai cac co dong khong co o nam sau
    Dim i&, k&
    For i = 1 To sR(j + 1, 0)
      dic(arr(j + 1)(i, 1)) = ""
    Next i
    For i = 1 To sR(j, 0)
      If dic.exists(arr(j)(i, 1)) Then
        k = k + 1
        arr(j)(k, 1) = arr(j)(i, 1)
        arr(j)(k, 2) = arr(j)(i, 2)
      End If
    Next i
    sR(j, 0) = k
    dic.RemoveAll
End Sub
 

File đính kèm

  • Danh sach CĐ 20182022.xlsb
    24.8 KB · Đọc: 22
Upvote 0
HieuCD đã viết:
Tạo sheet KQ lưu dữ liệu lọc. Chạy code XYZ
Mã: 
Option Explicit
Sub XYZ()
  Dim arr(), sR(), aRand, aRes(), tRes, res(), dic As Object
  Dim i&, r&, j&, c&
  Const N& = 4 '4 nam
  ReDim arr(1 To N):  ReDim sR(1 To N, 0 To 1): ReDim res(1 To N)
  Set dic = CreateObject("scripting.dictionary")
 
  With Sheets("Shareholder#")
    For j = 1 To N
      arr(j) = .Range(.Cells(3, j * 4 - 2), .Cells(3, j * 4 - 1).End(xlDown)).Value
      sR(j, 0) = UBound(arr(j))
      r = Int(sR(j, 0) / 4)
      ReDim aRow(1 To r)
      ReDim aRes(1 To r, 1 To 3)
      res(j) = aRes
    Next j
  End With
'Loai cac Co Dong khong co o nam sau
  For j = N - 1 To 1 Step -1
    Call CoDong(dic, arr, sR, j)
  Next j
'Chon cac gia tri ngau nhien
  Randomize
  For j = 1 To N
    aRand = UniqueRand(sR(j, 0))
    For r = 1 To UBound(aRand)
      If arr(j)(aRand(r), 1) <> Empty Then
        For c = j To N
          sR(c, 1) = sR(c, 1) + 1
          res(c)(sR(c, 1), 2) = arr(c)(aRand(r), 1)
          res(c)(sR(c, 1), 3) = arr(c)(aRand(r), 2)
          arr(c)(aRand(r), 1) = Empty
        Next c
        If sR(j, 1) = UBound(res(j)) Then Exit For
      End If
    Next r
  Next j
'Xep thu tu ngau nhien
  tRes = res
  For j = 1 To N
    aRand = UniqueRand(UBound(res(j)))
    For r = 1 To UBound(aRand)
      res(j)(r, 1) = r
      res(j)(r, 2) = tRes(j)(aRand(r), 2)
      res(j)(r, 3) = tRes(j)(aRand(r), 3)
    Next r
  Next j
'Gan ket qua
  With Sheets("KQ")
    For j = 1 To N
      .Cells(3, j * 4 - 3).Resize(UBound(res(j)), 3) = res(j)
    Next j
  End With
End Sub

Function UniqueRand(ByVal N As Long) As Variant 'Mang Day so ngau nhien 1 to N
  Dim arr&(), i&, RndNum&, tmp&
  ReDim arr&(1 To N)
  'Randomize
  For i = 1 To N
    RndNum = Int(N * Rnd() + 1)
    If arr(RndNum) = 0 Then tmp = RndNum Else tmp = arr(RndNum)
    If arr(N) = 0 Then arr(RndNum) = N Else arr(RndNum) = arr(N)
    arr(N) = tmp
    N = N - 1
  Next i
  UniqueRand = arr
End Function

Private Sub CoDong(dic, arr, sR, j)  'Loai cac co dong khong co o nam sau
    Dim i&, k&
    For i = 1 To sR(j + 1, 0)
      dic(arr(j + 1)(i, 1)) = ""
    Next i
    For i = 1 To sR(j, 0)
      If dic.exists(arr(j)(i, 1)) Then
        k = k + 1
        arr(j)(k, 1) = arr(j)(i, 1)
        arr(j)(k, 2) = arr(j)(i, 2)
      End If
    Next i
    sR(j, 0) = k
    dic.RemoveAll
End Sub
Nhấp chuột vào đây để mở rộng...
Chào Anh,

Cảm ơn anh đã giải quyết giúp vấn đề của em. Còn vấn để đếm được bao nhiêu tổ hợp kết quả thì có cách nào không anh?

Thanks a lot,
 
Upvote 0
duongde84 đã viết:
Chào Anh,

Cảm ơn anh đã giải quyết giúp vấn đề của em. Còn vấn để đếm được bao nhiêu tổ hợp kết quả thì có cách nào không anh?

Thanks a lot,
Nhấp chuột vào đây để mở rộng...
Dùng xác suất cổ điển để đếm, dạng tích xác suất nầy khá phức tạp, hơn 40 năm không đụng tới nên không nhớ công thức /-*+/ /-*+/ /-*+/
 
Upvote 0
duongde84 đã viết:
Ok anh. Em cảm ơn,
Nhấp chuột vào đây để mở rộng...
Chào anh,

Anh ơi kiểm tra giúp em với. Khi em thay tên vào vùng dữ liệu ở sheet "Shareholder#" thì chạy chương trình lại không thỏa mãn điều kiện là danh sách random của năm trước không là tập con của danh sách random của năm sau anh ạ. Với lại giờ em muốn thêm/bớt dữ liệu (thêm bớt số Cổ đông) ví dụ em thêm dữ liệu tới các ô mark màu vàng thì có ảnh hưởng đến chương trình không anh.

Cảm ơn anh nhiều,
 

File đính kèm

  • Danh sach CĐ 20182022-Mr Hieu.xlsb
    24.6 KB · Đọc: 9
Upvote 0
duongde84 đã viết:
Chào anh,

Anh ơi kiểm tra giúp em với. Khi em thay tên vào vùng dữ liệu ở sheet "Shareholder#" thì chạy chương trình lại không thỏa mãn điều kiện là danh sách random của năm trước không là tập con của danh sách random của năm sau anh ạ. Với lại giờ em muốn thêm/bớt dữ liệu (thêm bớt số Cổ đông) ví dụ em thêm dữ liệu tới các ô mark màu vàng thì có ảnh hưởng đến chương trình không anh.

Cảm ơn anh nhiều,
Nhấp chuột vào đây để mở rộng...
Thêm dữ liệu liên tục không có dòng trống
Chỉnh code
Mã: 
Sub XYZ()
  Dim arr(), sR(), aRand, aRes(), tRes, res(), dic As Object
  Dim i&, r&, j&, c&, tmp$
  Const N& = 4 '4 nam
  ReDim arr(1 To N):  ReDim sR(1 To N, 0 To 1): ReDim res(1 To N)
  Set dic = CreateObject("scripting.dictionary")
 
  With Sheets("Shareholder#")
    For j = 1 To N
      arr(j) = .Range(.Cells(3, j * 4 - 2), .Cells(3, j * 4 - 1).End(xlDown)).Value
      sR(j, 0) = UBound(arr(j))
      r = Int(sR(j, 0) / 4)
      ReDim aRow(1 To r)
      ReDim aRes(1 To r, 1 To 3)
      res(j) = aRes
    Next j
  End With
  On Error Resume Next
'Loai cac Co Dong khong co o nam sau
  For j = N - 1 To 1 Step -1
    Call CoDong(dic, arr, sR, j)
  Next j
'Chon cac gia tri ngau nhien
  Randomize
  For j = 1 To N
    aRand = UniqueRand(sR(j, 0))
    For r = 1 To UBound(aRand)
      tmp = arr(j)(aRand(r), 1)
      If tmp <> Empty Then
        For c = j To N
          sR(c, 1) = sR(c, 1) + 1
          For i = 1 To sR(c, 0)
            If arr(c)(i, 1) = tmp Then
              res(c)(sR(c, 1), 2) = tmp
              res(c)(sR(c, 1), 3) = arr(c)(i, 2)
              arr(c)(i, 1) = Empty
            End If
          Next i
        Next c
        If sR(j, 1) = UBound(res(j)) Then Exit For
      End If
    Next r
  Next j
'Xep thu tu ngau nhien
  tRes = res
  For j = 1 To N
    aRand = UniqueRand(UBound(res(j)))
    For r = 1 To UBound(aRand)
      res(j)(r, 1) = r
      res(j)(r, 2) = tRes(j)(aRand(r), 2)
      res(j)(r, 3) = tRes(j)(aRand(r), 3)
    Next r
  Next j
  If Err.Number > 0 Then MsgBox ("Du lieu khong thoa dieu kien!"): Exit Sub
'Gan ket qua
  With Sheets("KQ")
    For j = 1 To N
      .Cells(3, j * 4 - 3).Resize(UBound(res(j)), 3) = res(j)
    Next j
  End With
End Sub
 
Upvote 0
HieuCD đã viết:
Thêm dữ liệu liên tục không có dòng trống
Chỉnh code
Mã: 
Sub XYZ()
  Dim arr(), sR(), aRand, aRes(), tRes, res(), dic As Object
  Dim i&, r&, j&, c&, tmp$
  Const N& = 4 '4 nam
  ReDim arr(1 To N):  ReDim sR(1 To N, 0 To 1): ReDim res(1 To N)
  Set dic = CreateObject("scripting.dictionary")
 
  With Sheets("Shareholder#")
    For j = 1 To N
      arr(j) = .Range(.Cells(3, j * 4 - 2), .Cells(3, j * 4 - 1).End(xlDown)).Value
      sR(j, 0) = UBound(arr(j))
      r = Int(sR(j, 0) / 4)
      ReDim aRow(1 To r)
      ReDim aRes(1 To r, 1 To 3)
      res(j) = aRes
    Next j
  End With
  On Error Resume Next
'Loai cac Co Dong khong co o nam sau
  For j = N - 1 To 1 Step -1
    Call CoDong(dic, arr, sR, j)
  Next j
'Chon cac gia tri ngau nhien
  Randomize
  For j = 1 To N
    aRand = UniqueRand(sR(j, 0))
    For r = 1 To UBound(aRand)
      tmp = arr(j)(aRand(r), 1)
      If tmp <> Empty Then
        For c = j To N
          sR(c, 1) = sR(c, 1) + 1
          For i = 1 To sR(c, 0)
            If arr(c)(i, 1) = tmp Then
              res(c)(sR(c, 1), 2) = tmp
              res(c)(sR(c, 1), 3) = arr(c)(i, 2)
              arr(c)(i, 1) = Empty
            End If
          Next i
        Next c
        If sR(j, 1) = UBound(res(j)) Then Exit For
      End If
    Next r
  Next j
'Xep thu tu ngau nhien
  tRes = res
  For j = 1 To N
    aRand = UniqueRand(UBound(res(j)))
    For r = 1 To UBound(aRand)
      res(j)(r, 1) = r
      res(j)(r, 2) = tRes(j)(aRand(r), 2)
      res(j)(r, 3) = tRes(j)(aRand(r), 3)
    Next r
  Next j
  If Err.Number > 0 Then MsgBox ("Du lieu khong thoa dieu kien!"): Exit Sub
'Gan ket qua
  With Sheets("KQ")
    For j = 1 To N
      .Cells(3, j * 4 - 3).Resize(UBound(res(j)), 3) = res(j)
    Next j
  End With
End Sub
Nhấp chuột vào đây để mở rộng...
Dạ,

Cảm ơn anh nhiều,
 
Upvote 0
Bạn phải đăng nhập hoặc đăng ký để trả lời bài viết tại đây.
Web KT

Bài viết mới nhất

N
  • Question
Xin mã code ẩn hiện dòng theo điều kiện
Trả lời
10
Đọc
70
Nguyễn Diêu Hiền
N
K
  • Question
Sử dụng Power Query để xử lý nhật ký chung nhiều nợ nhiều có
    • Cười
Trả lời
11
Đọc
159
quocphuoc88
quocphuoc88
Huy@@*
Giải đáp giùm em, cách khắc phục lỗi này trên VBA
Trả lời
3
Đọc
39
Huy@@*
Huy@@*
N
cộng các dữ liệu không trùng nhau
Trả lời
9
Đọc
130
Nguyễn Hiền1508
N
N
Công thức tính số phù hợp với % mong muốn
Trả lời
9
Đọc
120
CHAOQUAY
C
B
Giúp em xử lý lỗi macro khi chạy VBA
2
Trả lời
21
Đọc
414
huhumalu
H
hunganh.nguyen
Xin giúp code tách dòng tổng thành những dòng chi tiết với giá trị là 1
Trả lời
6
Đọc
313
DeTong
D
T
cả nhà hỗ trợ giúp em là em phải dùng hàm gì cho đúng ạ, em làm mãi không được
    • Cười
Trả lời
2
Đọc
79
DeTong
D
nguyenanhhoa
Nhờ các bác giúp: e muốn tô màu khác nhau đối với các ô giống nhau về giá trị
    • Cười
Trả lời
7
Đọc
126
SA_DQ
SA_DQ
LuuAnh980
Từ "cân đối" trong tiếng Anh là gì?
2 3
Trả lời
44
Đọc
2K
VetMini
V
Hai Lúa Miền Tây
  • Question
Hàm chuyển dữ liệu từ cột sang dòng (Hàm melt + wide_to_long của Python trong Excel)
    • Thích
    • Cảm ơn
    • Yêu thích
Trả lời
11
Đọc
622
VetMini
V
C
Tiếng Việt
    • Cười
2
Trả lời
32
Đọc
1K
VetMini
V
HeSanbi
  • Question
Hàm FilterA và FilterV - Bổ trợ tận dụng bộ lọc AutoFilter và AdvancedFilter
    • Thích
    • Yêu thích
    • Cảm ơn
2 3
Trả lời
48
Đọc
4K
Manhhung90
Manhhung90
T
Chèn dữ liệu từ sheet này qua sheet khác theo điều kiện
Trả lời
1
Đọc
88
HieuCD
H
N
Giúp em công thức lấy dữ liệu không trùng để in phiếu thu bán hàng
Trả lời
5
Đọc
184
nguyenthieny
N
ongke0711
  • Question
Tải hóa đơn điện tử (https://hoadondientu.gdt.gov.vn/) Excel Vba
    • Thích
    • Yêu thích
7 8 9
Trả lời
173
Đọc
9K
ongke0711
ongke0711
vova2209
Index kết hợp với match 2 điều kiện
Trả lời
13
Đọc
1K
hoangtuaotrang_hp_vn
H
vova2209
  • Question
Tìm địa chỉ ô với 2đk và chuyển thành links
Trả lời
17
Đọc
398
vova2209
vova2209
A
Công thức tính tổng chi phí nhiều điều kiện
Trả lời
6
Đọc
113
adad
A
T
Lọc lấy đơn giá nhập mới nhất của các mặt hàng
2
Trả lời
20
Đọc
14K
honguyentruong
H
Xem thêm…

Thành viên có số lượng bài viết cao nhất tháng

Thành viên có điểm tương tác cao nhất tháng

Back
Top Bottom