Tìm Bộ 8 số xuất hiện nhiều nhất trong random( 1 - 80)

[Tuấn Bụng Bự]

Chào các bác !
Em có 1 bài toán khó nhờ các bác bắt bệnh xem có thế code VBA giải quyết được không ạ !?

Input:
- bảng dữ liệu A3:T102 gồm 20 cột và 100 hàng
- Dữ liệu trong bảng là random từ 1 - 80 và mỗi hàng các số không lặp lại

Output:
Tìm ra 8 bộ số mà nó xuất hiện đồng thời trong 1 hàng và nó xuất hiện ở nhiều hàng nhất

Bộ số ví dụ ( không phải kết quả)	47​	25​	62​	61​	34​	70​	64​	30​
Số lần xuất hiện 8 bộ số này đồng thời trong mỗi hàng là 1 lần (chỉ ở hàng 3)

Xin cảm ơn các bác đã đọc bài.

 

[Tuấn Bụng Bự]

Macro trên cùng có 2 nhiệm vụ:
1 là Tạo 1 chuỗi chứa các số từ 01,02. . . 80;
Tạo 1 vòng lặp trích ra từ chuỗi vừa tạo 20 số (không trùng cho từng hàng chẵn hay lẽ phụ thuộc theo ngày;
Macro 2: Tìm kiếm theo từng hàng 8 con số nhiếu nhất trong bảng có bao nhiêu số & ghi nhận lại
Macro 3 : Sắp xếp theo chiều giảm dần của các số trùng lặp nhiều nhất (Macro nhờ bộ thu của VBE)

Sub Tao20SoNgauBeHon81() : em hiểu nó làm nhiệm vụ tạo data để test code, data thì có sẵn rồi ạ, và em cũng đã code 1 chương trình tạo dữ liệu 20 số không trùng lặp trong 1 hàng và chạy 100 hàng. em dùng Dic để ko có trùng lặp, code bác em học thêm được câu lệnh randomize ạ.

Sub TimKiem() : cái này chưa đúng yêu cầu, yêu cầu tìm ra bộ 8 số mà bộ 8 số đó xuất hiện đồng thời ở nhiều hàng dữ liệu nhất ạ

Sub SapXep() : chắc phục vụ cho Sub tìm kiếm của bác

Bài đã được tự động gộp: 16/11/24

Cái này chứng minh loại trừ cũng dễ mà bạn

chứng mình thì ko hẵn, em cần cách tìm ra bộ số đó. nếu ko tiện chia sẻ ở đây bác cho em xin thông tin liên hệ ạ

Bài đã được tự động gộp: 16/11/24

Bạn đúng là ông vua của kỹ thuật số. Khâm phục khâm phục.

Tác giả: đầu tiên tổng hợp ra 12 triệu bộ số như trên đã, loại bỏ trùng rồi cho lặp thôi. Nếu biết code thì chắc làm ngon.

em gà mờ về VBA thôi, đang nghiên cứu và tham khảo các bác ạ

 

[HeSanbi]

Môn này là Vietlott hay Keno vậy bạn, nếu liên quan tới trò chơi ăn thua trúng thưởng, thì mình khuyên bạn nên sớm từ bỏ.
Nếu dùng trí tuệ và công sức học tập để vào những việc này thì hại nhiều mà lợi không thấy đâu.

Dùng não bộ để tính toán bạn sẽ mất đi hàng tỉ nơ-ron quý giá, mất rồi muốn có lại phải ăn thật nhiều đồ ăn bổ dưỡng, bộ não mà đến giai đoạn không còn khả năng tư duy nữa thì hối tiếc không kịp.
Nên để dành cho việc lành mạnh sẽ có ích và có lợi. Chấp nhận làm công có lương, tích lũy ít từ từ sẽ có nhiều.

 

[Tuấn Bụng Bự]

Môn này là Vietlott hay Keno vậy bạn, nếu liên quan tới trò chơi ăn thua trúng thưởng, thì mình khuyên bạn nên sớm từ bỏ.
Nếu dùng trí tuệ và công sức học tập để vào những việc này thì hại nhiều mà lợi không thấy đâu.

Dùng não bộ để tính toán bạn sẽ mất đi hàng tỉ nơ-ron quý giá, mất rồi muốn có lại phải ăn thật nhiều đồ ăn bổ dưỡng, bộ não mà đến giai đoạn không còn khả năng tư duy nữa thì hối tiếc không kịp.
Nên để dành cho việc lành mạnh sẽ có ích và có lợi. Chấp nhận làm công có lương, tích lũy ít từ từ sẽ có nhiều.

cảm ơn bác, em chỉ là rèn luyện code thôi ạ. có bác chỉ em học về tổ hợp và đệ quy, em đang nghiên cứu tiếp

 

[SA_DQ]

Cái khác nhau giữa bạn & mình là ở chỗ: Bạn đi tìm 8 số cho trước; Còn mình là đi tìm 8 số mà các số này có nhiều nhất trong bảng số liệu của bạn;
Vì bạn để ngay dòng đầu tiên là kết quả & là kết quả duy nhất, nên mình cho vòng lặp tìm từ dưới lên & chỉ mất chưa đến .3 gy thôi:

22

23

24

25

26

8​

Số

Lặp

0.25​

8​

20

33​

47​

5

32​

25​

6

32​

62​

13

32​

61​

5​

27

32​

34​

40

32​

70​

30

31​

64​

62

31​

30​

Chú thích hình:
→ Các số trên hàng trên cùng là chỉ số cột (trên trang tính của bạn & dược nối thêm tới 26)
→ Các số từ 47 tới 30 của cột 26 này là những con số bạn tự chọn
→ (Các con số từ 20 đến 62 là số trong bảng của bạn có số lần lặp lại lớn nhất
& đây cũng là 8 con số mình lấy ra để đi tìm trong đống dữ liệu của bạn)
→ Con số 0.25 là thời gian tiêu tốn cho macro dưới đây để tìm ra theo iêu cầu của bạn

Sub Tim8SoTuCacHang()
 Dim Rng As Range, sRng As Range, Cls As Range, tRg As Range
 Dim Tmr As Double, J As Integer, W8 As Integer, Max8 As Integer
 
 Set tRg = [Z3:Z10]:                    Tmr = Timer()
 For J = 102 To 3 Step -1
    Set Rng = Cells(J, "A").Resize(, 20)
    For Each Cls In tRg
        Set sRng = Rng.Find(Cls.Value, , xlFormulas, xlWhole)
        If Not sRng Is Nothing Then
            W8 = W8 + 1
        End If
    Next Cls
    If W8 > Max8 Then
        Cells(J, "V").Value = W8:       Max8 = W8
    End If
    W8 = 0
 Next J
 [Z2].Value = Timer() - Tmr
End Sub

Thân & chúc vui nha!

 

[bebo021999]

Vì không rõ lắm kết quả của bạn muốn có là gì, nên mình cho liệt kê hết các bộ 8 số (trong mỗi bộ sort theo thứ tự A-Z)
cùng với số thứ tự dòng chứa bộ số đó (trong mỗi dòng thì 8 số đó xuất hiện ngẫu nhiên không theo thứ tự)
Từ bảng kết quả đó, bạn có thể sort, filter hay trích xuất theo điều kiện nào đó thì tùy bạn

Option Explicit
Sub RandSetNumber()
Dim lr&, i&, j&, k&, m&, n&, tmp, res(1 To 10000, 1 To 2), t, st As String, st2 As String
Dim r&, c&, so As String, dong As String, rng
Dim dic As Object, dic2 As Object
Set dic = CreateObject("Scripting.dictionary"): Set dic2 = CreateObject("Scripting.dictionary")
t = Timer
lr = Cells(Rows.Count, "A").End(xlUp).Row
rng = Range("A3:T" & lr).Value

'sort tung dòng theo thu tu tang dan tu trai sang phai
For i = 1 To UBound(rng)
    For m = 1 To UBound(rng, 2) - 1
        For n = m + 1 To UBound(rng, 2)
            If rng(i, n) < rng(i, m) Then
                tmp = rng(i, n): rng(i, n) = rng(i, m): rng(i, m) = tmp
            End If
        Next
    Next
Next

'so sanh tung dong voi cac dong con lai, neu so o = nhau >=8 thi cong don vao c
'sau do luu ket qua vao array res
For i = 1 To UBound(rng)
    c = 0
    For j = 1 To UBound(rng)
        st = i & ", " & j: st2 = j & ", " & i
        If j <> i And Not dic2.exists(st2) Then
            r = 0: so = "": dong = i '
            For n = 1 To UBound(rng, 2)
                For m = 1 To UBound(rng, 2)
                    If rng(j, n) = rng(i, m) Then
                        so = IIf(so = "", "", so & ", ") & rng(j, n)
                        r = r + 1
                    End If
                Next
            Next
            If r >= 8 Then
                c = c + 1
                dic2.Add st, ""
                dong = IIf(dong = "", "", dong & ", ") & j
                k = k + 1: res(k, 1) = so: res(k, 2) = dong
            End If
        End If
    Next
Next
If k = 0 Then Exit Sub

'Loai trung BO SO, noi chuoi ket qua o
For i = 1 To k
    If Not dic.exists(res(i, 1)) Then
        dic.Add res(i, 1), res(i, 2)
    Else
        dic(res(i, 1)) = dic(res(i, 1)) & ", " & res(i, 2)
    End If
Next

'Dan ket qua vao sheet
With Range("V8")
    .Resize(10000, 2).ClearContents
    .Resize(dic.Count, 2).Value = WorksheetFunction.Transpose(Array(dic.keys, dic.items))
End With
MsgBox Timer - t
End Sub

 

[truongvu317]

Như này có vẻ thấy đúng, cách làm ở bài 26 thì được tầm 95%, phát triển thêm chắc sẽ mượt mà tầm vài giây.

 

[cantl]

Cùng đáp án này thì tác giả phải liên hệ ông hoàng lô đề bán cháo quẩy rồi.

 

[Tuấn Bụng Bự]

Cái khác nhau giữa bạn & mình là ở chỗ: Bạn đi tìm 8 số cho trước;

Chào anh/chị.

Em có file excel dữ liệu đính kèm. Trong file có sheet data là dữ liệu em đã chuẩn bị sẵn. Nhờ anh/chị hướng dẫn giúp em cách lọc được dữ liệu những cột ( từ cột I đến cột M) thể hiện giờ chấm công ở sheet Data để đưa sang sheet Kết quả.

Cám ơn anh/chị.

Dim Tmr As Double
Sub Tao20SoNgauBeHon81()    'Ctrl+Shift+N'
 Dim W As Integer, SoNgau As Integer, Hg As Integer
 Dim Tmp As String, sTp As String
 
 Tmr = Timer()
1 For W = 1 To 80    'Vòng Lap Tao Chuoi Cua 80 Sô    '
    Tmp = Tmp & Right("0" & CStr(W), 2)
 Next W
 Randomize
2 ' Vong Lap Tao Lai 1 Nua Sô Hàng Mà Môi Hàng 20 Sô Không Lap   '
 For Hg = IIf(Day(Date) Mod 2 = 0, 4, 3) To 102 Step 2
    sTp = Tmp:                      ReDim Arr(1 To 1, 1 To 20)
    For W = 1 To 20
        SoNgau = 3 + 35 * Rnd() \ 1
        If SoNgau Mod 2 = 0 Then SoNgau = SoNgau + 1
        Arr(1, W) = Mid$(sTp, SoNgau, 2)
        Tmp = Mid(sTp, SoNgau + 2, Len(sTp)) & Left(sTp, SoNgau - 2)
    Next W
    Cells(Hg, "A").Resize(, 20).Value = Arr()
'    Erase Arr()    '
 Next Hg
 SapXep
 TimKiem
 MsgBox Timer() - Tmr
End Sub

Sub TimKiem()
 Dim Arr(), Rng As Range, sRng As Range, Rg0 As Range, Cls As Range
 Dim W As Integer, J As Integer, Dem As Integer, Num As Integer, Tmr As Double, Max_ As Integer
 
 [U3:U102].Clear
 For J = 102 To 3 Step -1
    Set Rng = Cells(J, "A").Resize(, 20)
    For Each Cls In [W2:W9]
        Set sRng = Rng.Find(Cls.Value, , xlFormulas, xlWhole)
        If Not sRng Is Nothing Then Dem = Dem + 1
    Next Cls
    If Dem > Max_ Then
        Cells(J, "J").Interior.ColorIndex = 34 + Dem
        Cells(J, "U").Value = Dem:  Max_ = Dem
    End If
    Dem = 0
 Next J
End Sub

Sub SapXep() ' Keyboard Shortcut: Ctrl+Shift+X'
 Columns("W:X").Select
 ActiveWorkbook.Worksheets("DuLieu").Sort.SortFields.Clear
 ActiveWorkbook.Worksheets("DuLieu").Sort.SortFields.Add2 Key:=Range("X2:X103" _
        ), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
 With ActiveWorkbook.Worksheets("DuLieu").Sort
    .SetRange Range("W1:X103"):     .Header = xlYes
    .MatchCase = False:             .Orientation = xlTopToBottom
    .SortMethod = xlPinYin:         .Apply
 End With
End Sub

Trên này có vẻ chỉ có tớ và cậu đam mê Đề án phát triển sông Lô. Xin được gọi 1 tiếng đồng chí.

Cái khác nhau giữa bạn & mình là ở chỗ: Bạn đi tìm 8 số cho trước; Còn mình là đi tìm 8 số mà các số này có nhiều nhất trong bảng số liệu của bạn;
Vì bạn để ngay dòng đầu tiên là kết quả & là kết quả duy nhất, nên mình cho vòng lặp tìm từ dưới lên & chỉ mất chưa đến .3 gy thôi:

22

23

24

25

26

8​

Số

Lặp

0.25​

8​

20

33​

47​

5

32​

25​

6

32​

62​

13

32​

61​

5​

27

32​

34​

40

32​

70​

30

31​

64​

62

31​

30​

Chú thích hình:
→ Các số trên hàng trên cùng là chỉ số cột (trên trang tính của bạn & dược nối thêm tới 26)
→ Các số từ 47 tới 30 của cột 26 này là những con số bạn tự chọn
→ (Các con số từ 20 đến 62 là số trong bảng của bạn có số lần lặp lại lớn nhất
& đây cũng là 8 con số mình lấy ra để đi tìm trong đống dữ liệu của bạn)
→ Con số 0.25 là thời gian tiêu tốn cho macro dưới đây để tìm ra theo iêu cầu của bạn

Sub Tim8SoTuCacHang()
 Dim Rng As Range, sRng As Range, Cls As Range, tRg As Range
 Dim Tmr As Double, J As Integer, W8 As Integer, Max8 As Integer
 
 Set tRg = [Z3:Z10]:                    Tmr = Timer()
 For J = 102 To 3 Step -1
    Set Rng = Cells(J, "A").Resize(, 20)
    For Each Cls In tRg
        Set sRng = Rng.Find(Cls.Value, , xlFormulas, xlWhole)
        If Not sRng Is Nothing Then
            W8 = W8 + 1
        End If
    Next Cls
    If W8 > Max8 Then
        Cells(J, "V").Value = W8:       Max8 = W8
    End If
    W8 = 0
 Next J
 [Z2].Value = Timer() - Tmr
End Sub

Thân & chúc vui nha!

Còn mình là đi tìm 8 số mà các số này có nhiều nhất trong bảng số liệu của bạn

Bác đang hiểu sai yêu cầu . Nó phải thoả mãn là cả bộ 8 số này cùng xuất hiện trong 1 hàng mới tính là 1 lần. và thêm yêu cầu số 2 là cả bộ đó xuất hiện đồng thời ở nhiều hàng nhất ạ.

;
Vì bạn để ngay dòng đầu tiên là kết quả & là kết quả duy nhất, nên mình cho vòng lặp tìm từ dưới lên & chỉ mất chưa đến .3 gy thôi:

22

23

24

25

26

8​

Số

Lặp

0.25​

8​

20

33​

47​

5

32​

25​

6

32​

62​

13

32​

61​

5​

27

32​

34​

40

32​

70​

30

31​

64​

62

31​

30​

Chú thích hình:
→ Các số trên hàng trên cùng là chỉ số cột (trên trang tính của bạn & dược nối thêm tới 26)
→ Các số từ 47 tới 30 của cột 26 này là những con số bạn tự chọn
→ (Các con số từ 20 đến 62 là số trong bảng của bạn có số lần lặp lại lớn nhất
& đây cũng là 8 con số mình lấy ra để đi tìm trong đống dữ liệu của bạn)
→ Con số 0.25 là thời gian tiêu tốn cho macro dưới đây để tìm ra theo iêu cầu của bạn

Sub Tim8SoTuCacHang()
 Dim Rng As Range, sRng As Range, Cls As Range, tRg As Range
 Dim Tmr As Double, J As Integer, W8 As Integer, Max8 As Integer
 
 Set tRg = [Z3:Z10]:                    Tmr = Timer()
 For J = 102 To 3 Step -1
    Set Rng = Cells(J, "A").Resize(, 20)
    For Each Cls In tRg
        Set sRng = Rng.Find(Cls.Value, , xlFormulas, xlWhole)
        If Not sRng Is Nothing Then
            W8 = W8 + 1
        End If
    Next Cls
    If W8 > Max8 Then
        Cells(J, "V").Value = W8:       Max8 = W8
    End If
    W8 = 0
 Next J
 [Z2].Value = Timer() - Tmr
End Sub

Thân & chúc vui nha!

" Vì bạn để ngay dòng đầu tiên là kết quả & là kết quả duy nhất, nên mình cho vòng lặp tìm từ dưới lên & chỉ mất chưa đến .3 gy thôi: "
===> em chưa có tìm được kết quả đáp án, như bài viết chú thích đó không phải là kết quả mà chỉ là ví dụ cho các bác hiểu bộ 8 số xuất hiện đồng thời là như nào ạ

Bài đã được tự động gộp: 17/11/24

Vì không rõ lắm kết quả của bạn muốn có là gì, nên mình cho liệt kê hết các bộ 8 số (trong mỗi bộ sort theo thứ tự A-Z)
cùng với số thứ tự dòng chứa bộ số đó (trong mỗi dòng thì 8 số đó xuất hiện ngẫu nhiên không theo thứ tự)
Từ bảng kết quả đó, bạn có thể sort, filter hay trích xuất theo điều kiện nào đó thì tùy bạn

Option Explicit
Sub RandSetNumber()
Dim lr&, i&, j&, k&, m&, n&, tmp, res(1 To 10000, 1 To 2), t, st As String, st2 As String
Dim r&, c&, so As String, dong As String, rng
Dim dic As Object, dic2 As Object
Set dic = CreateObject("Scripting.dictionary"): Set dic2 = CreateObject("Scripting.dictionary")
t = Timer
lr = Cells(Rows.Count, "A").End(xlUp).Row
rng = Range("A3:T" & lr).Value

'sort tung dòng theo thu tu tang dan tu trai sang phai
For i = 1 To UBound(rng)
    For m = 1 To UBound(rng, 2) - 1
        For n = m + 1 To UBound(rng, 2)
            If rng(i, n) < rng(i, m) Then
                tmp = rng(i, n): rng(i, n) = rng(i, m): rng(i, m) = tmp
            End If
        Next
    Next
Next

'so sanh tung dong voi cac dong con lai, neu so o = nhau >=8 thi cong don vao c
'sau do luu ket qua vao array res
For i = 1 To UBound(rng)
    c = 0
    For j = 1 To UBound(rng)
        st = i & ", " & j: st2 = j & ", " & i
        If j <> i And Not dic2.exists(st2) Then
            r = 0: so = "": dong = i '
            For n = 1 To UBound(rng, 2)
                For m = 1 To UBound(rng, 2)
                    If rng(j, n) = rng(i, m) Then
                        so = IIf(so = "", "", so & ", ") & rng(j, n)
                        r = r + 1
                    End If
                Next
            Next
            If r >= 8 Then
                c = c + 1
                dic2.Add st, ""
                dong = IIf(dong = "", "", dong & ", ") & j
                k = k + 1: res(k, 1) = so: res(k, 2) = dong
            End If
        End If
    Next
Next
If k = 0 Then Exit Sub

'Loai trung BO SO, noi chuoi ket qua o
For i = 1 To k
    If Not dic.exists(res(i, 1)) Then
        dic.Add res(i, 1), res(i, 2)
    Else
        dic(res(i, 1)) = dic(res(i, 1)) & ", " & res(i, 2)
    End If
Next

'Dan ket qua vao sheet
With Range("V8")
    .Resize(10000, 2).ClearContents
    .Resize(dic.Count, 2).Value = WorksheetFunction.Transpose(Array(dic.keys, dic.items))
End With
MsgBox Timer - t
End Sub

Em cũng đang đi theo hướng liệt kê tất cả các bộ 8 số từ bảng dữ liệu ra để xét
nhưng em thấy có vẻ bác làm chưa ổn, đây là tổ hợp bộ 8 số từ 1 hàng 20 số = 125970 . nhân với 100 hàng thì kết quả phải là 1 259 700 kết quả chứ bác

Bài đã được tự động gộp: 17/11/24

Như này có vẻ thấy đúng, cách làm ở bài 26 thì được tầm 95%, phát triển thêm chắc sẽ mượt mà tầm vài giây.
View attachment 305652

chưa hiểu ý bạn lắm

 

[bebo021999]

Em cũng đang đi theo hướng liệt kê tất cả các bộ 8 số từ bảng dữ liệu ra để xét
nhưng em thấy có vẻ bác làm chưa ổn, đây là tổ hợp bộ 8 số từ 1 hàng 20 số = 125970 . nhân với 100 hàng thì kết quả phải là 1 259 700 kết quả chứ bác

Liệt kê ra hơn 1 triệu kết quả thì biết lưu ở đâu?
Mà liệt kê ra làm gì.
Kết quả mình làm là căn cứ 100 dòng có sẵn, liệt kê ra các bộ 8 số mà xuất hiện từ 2 dòng trở lên.

 

[huuthang_bd]

Code bài #6 sửa lại sử dụng nhiều dic là ngon lành ngay.

Sub xyz()
  Dim arr(), a, dic As Object
  Dim sR&, sC&, sR2&, i&, r&, k&, n&, j&, iMax&, t$, res$
 
  'Set dic = CreateObject("scripting.dictionary")
  Dim aTmp(1 To 8)
  Dim ArrDic(1 To 73, 2 To 74) As Object
  For i = 1 To 73
    For j = 2 To 74
      Set ArrDic(i, j) = CreateObject("scripting.dictionary")
    Next
  Next
 
  arr = Range("A3:T102").Value
  sR = UBound(arr):     sC = UBound(arr, 2)
  k = 8
  Call aSort(arr, sR, sC&, 80)
  a = Tohop_N_Chap_K(sC, k)
  sR2 = UBound(a)
  For i = 1 To sR
    For r = 1 To sR2
    
'      t = arr(i, a(r, 1))
'      For j = 2 To k
'        t = t & "," & arr(i, a(r, j))
'      Next j
'      n = dic(t) + 1
'      dic(t) = n
      For j = 1 To k
        aTmp(j) = arr(i, a(r, j))
      Next j
      t = Join(aTmp, ",")
      n = ArrDic(aTmp(1), aTmp(2))(t) + 1
      ArrDic(aTmp(1), aTmp(2))(t) = n
      
      If iMax < n Then
        iMax = n
        res = t
      End If
    Next r
  Next i
  Range("X6") = res
  Range("X7") = iMax
End Sub

Private Sub aSort(arr, sR, sC, ByVal n&)
  Dim a&(), i&, j&, c&
 
  For i = 1 To sR
    ReDim a(1 To n): c = 0
    For j = 1 To sC
      a(arr(i, j)) = 1
    Next j
    For j = 1 To n
      If a(j) = 1 Then
        c = c + 1
        arr(i, c) = j
      End If
    Next j
  Next i
End Sub

Private Function Tohop_N_Chap_K(ByVal n As Integer, ByVal k As Integer) As Variant
  Dim arr(), tmp$, sR&, i&, j&, p&, s&
  'Tao to hop N chap K, bieu dien bang chuoi các k? tu "0" va "1"
  'Thu tu gia tri "1" là thu tu du lieu nguon lay du lieu
  sR = Application.Combin(n, k)
  ReDim arr(1 To Application.Combin(n, k), 1 To k)
  tmp = String(k, "1") & String(n - k, "0")
  p = 1: arr(p, 1) = tmp
  Do
    j = InStrRev(tmp, "1")
    Mid(tmp, j, 1) = "0"
    Mid(tmp, j + 1, s + 1) = String(s + 1, "1")
    s = 0: p = p + 1:   arr(p, 1) = tmp
    If InStr(j + 1, tmp, "0") = 0 Then
      s = n - j
      Mid(tmp, j + 1, s) = String(s, "0")
    End If
  Loop Until s = k
  'Tao mang to hop N chap K, gia tri mang là thu tu cot lay du lieu tu mang nguon
  For i = 1 To sR
    tmp = arr(i, 1):    p = 0
    For j = 1 To n
      If Mid(tmp, j, 1) = "1" Then
        p = p + 1
        arr(i, p) = j
      End If
    Next j
  Next i
  Tohop_N_Chap_K = arr
End Function

 

[Tuấn Bụng Bự]

Liệt kê ra hơn 1 triệu kết quả thì biết lưu ở đâu?
Mà liệt kê ra làm gì.
Kết quả mình làm là căn cứ 100 dòng có sẵn, liệt kê ra các bộ 8 số mà xuất hiện từ 2 dòng trở lên.

Thanks bác đã quan tâm.
Em xem kết quả file bác thì bác liệt kê các bộ số lúc thì 8, lúc thì 9, lúc thì 10 số .

Bài đã được tự động gộp: 19/11/24

Code bài #6 sửa lại sử dụng nhiều dic là ngon lành ngay.

Sub xyz()
  Dim arr(), a, dic As Object
  Dim sR&, sC&, sR2&, i&, r&, k&, n&, j&, iMax&, t$, res$
 
  'Set dic = CreateObject("scripting.dictionary")
  Dim aTmp(1 To 8)
  Dim ArrDic(1 To 73, 2 To 74) As Object
  For i = 1 To 73
    For j = 2 To 74
      Set ArrDic(i, j) = CreateObject("scripting.dictionary")
    Next
  Next
 
  arr = Range("A3:T102").Value
  sR = UBound(arr):     sC = UBound(arr, 2)
  k = 8
  Call aSort(arr, sR, sC&, 80)
  a = Tohop_N_Chap_K(sC, k)
  sR2 = UBound(a)
  For i = 1 To sR
    For r = 1 To sR2
   
'      t = arr(i, a(r, 1))
'      For j = 2 To k
'        t = t & "," & arr(i, a(r, j))
'      Next j
'      n = dic(t) + 1
'      dic(t) = n
      For j = 1 To k
        aTmp(j) = arr(i, a(r, j))
      Next j
      t = Join(aTmp, ",")
      n = ArrDic(aTmp(1), aTmp(2))(t) + 1
      ArrDic(aTmp(1), aTmp(2))(t) = n
     
      If iMax < n Then
        iMax = n
        res = t
      End If
    Next r
  Next i
  Range("X6") = res
  Range("X7") = iMax
End Sub

Private Sub aSort(arr, sR, sC, ByVal n&)
  Dim a&(), i&, j&, c&
 
  For i = 1 To sR
    ReDim a(1 To n): c = 0
    For j = 1 To sC
      a(arr(i, j)) = 1
    Next j
    For j = 1 To n
      If a(j) = 1 Then
        c = c + 1
        arr(i, c) = j
      End If
    Next j
  Next i
End Sub

Private Function Tohop_N_Chap_K(ByVal n As Integer, ByVal k As Integer) As Variant
  Dim arr(), tmp$, sR&, i&, j&, p&, s&
  'Tao to hop N chap K, bieu dien bang chuoi các k? tu "0" va "1"
  'Thu tu gia tri "1" là thu tu du lieu nguon lay du lieu
  sR = Application.Combin(n, k)
  ReDim arr(1 To Application.Combin(n, k), 1 To k)
  tmp = String(k, "1") & String(n - k, "0")
  p = 1: arr(p, 1) = tmp
  Do
    j = InStrRev(tmp, "1")
    Mid(tmp, j, 1) = "0"
    Mid(tmp, j + 1, s + 1) = String(s + 1, "1")
    s = 0: p = p + 1:   arr(p, 1) = tmp
    If InStr(j + 1, tmp, "0") = 0 Then
      s = n - j
      Mid(tmp, j + 1, s) = String(s, "0")
    End If
  Loop Until s = k
  'Tao mang to hop N chap K, gia tri mang là thu tu cot lay du lieu tu mang nguon
  For i = 1 To sR
    tmp = arr(i, 1):    p = 0
    For j = 1 To n
      If Mid(tmp, j, 1) = "1" Then
        p = p + 1
        arr(i, p) = j
      End If
    Next j
  Next i
  Tohop_N_Chap_K = arr
End Function

Cảm ơn bác để em nghiên cứu code này học hỏi ạ

 

[VetMini]

Cảm ơn bác đã đọc và hỗ trợ
Code em vừa test tràn bộ nhớ. để mai em mượn máy bạn test lại ạ

Code của bạn ấy (bài #6) có hàm đệ quy. Một trong những khuyết điểm của đệ quy là số lượng gọi đệ quy. Nếu số lượng này cao là tràn bộ nhớ dễ dàng.

Bạ cần làm cái gì thật quan trọng thì hãy đeo đuổi tiếp. Nếu không thì đề bài tôi nói thẳng là không phù hợp với dân chỉ code hạng trung trung.
1. VBA là code lập trình ứng dụng. Bài này đòi hỏi lập trình Toán.
Nên giải nó bằng các ngôn ngữ chuyên thống kê, hoặc có thể import các phần mềm thóng kê viết từ dân ngoại hạng, như Python, R,...
2. Bạn có thể bảo rằng "dùng để học lập trình". Nhưng học kiểu này là lạc đường rồi.
Bài này phải chia ra thành từng phần nhỏ và tìm giải pháp tối ưu cho các phần ấy.
Các pháp ấy có thể ứng dụng nhiều kỹ thuật chuyên Toán mà phải trên cấp đại học mới học tới.

 

[Tuấn Bụng Bự]

Code của bạn ấy (bài #6) có hàm đệ quy. Một trong những khuyết điểm của đệ quy là số lượng gọi đệ quy. Nếu số lượng này cao là tràn bộ nhớ dễ dàng.

Bạ cần làm cái gì thật quan trọng thì hãy đeo đuổi tiếp. Nếu không thì đề bài tôi nói thẳng là không phù hợp với dân chỉ code hạng trung trung.
1. VBA là code lập trình ứng dụng. Bài này đòi hỏi lập trình Toán.
Nên giải nó bằng các ngôn ngữ chuyên thống kê, hoặc có thể import các phần mềm thóng kê viết từ dân ngoại hạng, như Python, R,...
2. Bạn có thể bảo rằng "dùng để học lập trình". Nhưng học kiểu này là lạc đường rồi.
Bài này phải chia ra thành từng phần nhỏ và tìm giải pháp tối ưu cho các phần ấy.
Các pháp ấy có thể ứng dụng nhiều kỹ thuật chuyên Toán mà phải trên cấp đại học mới học tới.

Vâng em đang đi theo hướng "Đệ Quy" code thì có rồi , hàm đệ quy có mấy dòng thôi mà em đang loạn não chưa hiểu được cái đoạn nó tự gọi lại chính nó
Em dân ko chuyên, công việc làm phải dùng đến VBA nên học bác ạ.
còn bài toán này là vô tình thấy trên nhóm fb nên tìm hiểu chơi ạ