Option Explicit
Sub xxx()
Dim Nguon
Dim Thongke, Spt
Dim Tam, Mang0, Mang1, csD
Dim bac, chuky, cap
Dim congSl, ghSl
Dim Kq
Dim rws, i, j, k, x, z, t
With Sheet1
bac = .Range("B3")
chuky = .Range("C3")
cap = .Range("D3")
End With
Spt = 80
ReDim Tam(1 To Spt)
With Sheet2
Thongke = .Range("C2", .Range("C2").End(xlToRight).End(xlDown))
rws = UBound(Thongke)
ReDim Nguon(1 To rws)
For i = 1 To rws
For j = 1 To UBound(Thongke, 2)
Tam(Thongke(i, j)) = Thongke(i, j)
Next j
Nguon(i) = Tam
For j = 1 To Spt
Tam(j) = 0
Next j
Next i
End With
If chuky > rws Or cap = 0 Then
MsgBox "Xem lai chu ky"
Exit Sub
End If
ghSl = cap * bac
With CreateObject("Scripting.Dictionary")
ReDim csD(1 To chuky)
For i = 1 To chuky
csD(1) = i
.Item(.Count) = Array(1, csD, Nguon(i))
Next i
Do While .Count > 0
Thongke = .items
.RemoveAll
t = t + 1
For i = 0 To UBound(Thongke)
k = Thongke(i)(0)
csD = Thongke(i)(1)
Mang0 = Thongke(i)(2)
If csD(k) + 1 <= chuky Then
For j = csD(k) + 1 To chuky
congSl = 0
Mang1 = Nguon(j)
For z = 1 To Spt
If Mang0(z) > 0 And Mang1(z) > 0 Then
congSl = congSl + 1
Tam(z) = z
End If
Next z
If congSl >= ghSl Then
csD(k + 1) = j
.Item(.Count) = Array(k + 1, csD, Tam, congSl)
End If
For z = 1 To Spt
Tam(z) = 0
Next z
Next j
End If
Next i
Loop
End With
ReDim Kq(1 To UBound(Thongke) + 1, 1 To 2)
Sheet1.Range("H3").Resize(rws * rws, UBound(Kq, 2)).Clear
If t > 1 Then
For i = 0 To UBound(Thongke)
k = 0
Mang0 = Thongke(i)(2)
csD = Thongke(i)(1)
Kq(i + 1, 1) = Application.Trim(Join(csD))
Kq(i + 1, 2) = Application.Trim(Replace(Join(Mang0), "0", ""))
Next i
Sheet1.Range("H3").Resize(UBound(Kq), UBound(Kq, 2)) = Kq
Sheet1.UsedRange.Columns.AutoFit
Else
MsgBox "Khong co cap nao"
End If
End Sub
