Tìm nhóm số với số cột lớn nhất

Liên hệ QC
HieuCD đã viết:
để khắc phục lổi dòng lệnh
Dic2.Add tmp, i
bạn thay bằng lệnh
If Not Dic2.exists(tmp) Then Dic2.Add tmp, i

tóm lại chỉ cần tìm 80 số (hoặc nhỏ hơn 80 số được không?) không trùng trong 100 số từ 00 đến 99 ? sao cho tất cả 400 cột đều chứa 1 trong 80 số đó, hoặc ít hơn 400 nhưng lấy số cột lớn nhất
Nhấp chuột vào đây để mở rộng...
Dạ, vâng đúng như ý hiểu của bạn rồi bạn ạ: Chỉ cần tìm nhóm số không trùng trong 100 số từ 00 đến 99 sao cho tất cả 400 cột đều chứa 1 trong các số đó, hoặc ít hơn 400 nhưng lấy số cột lớn nhất. (nếu tạo được hộp thông báo nhập số liệu cho các trường hợp trước khi chạy code: ví dụ như trường hợp tìm nhóm 80 số mình chỉ việc nhập 80 và chạy code để tìm, hoặc tìm nhóm 70 số chỉ việc nhập 70 và chạy code để tìm,..v.v.v.). Cảm ơn bạn giúp đỡ mình!
 
Sơn Mã đã viết:
Dạ, vâng đúng như ý hiểu của bạn rồi bạn ạ: Chỉ cần tìm nhóm số không trùng trong 100 số từ 00 đến 99 sao cho tất cả 400 cột đều chứa 1 trong các số đó, hoặc ít hơn 400 nhưng lấy số cột lớn nhất. (nếu tạo được hộp thông báo nhập số liệu cho các trường hợp trước khi chạy code: ví dụ như trường hợp tìm nhóm 80 số mình chỉ việc nhập 80 và chạy code để tìm, hoặc tìm nhóm 70 số chỉ việc nhập 70 và chạy code để tìm,..v.v.v.). Cảm ơn bạn giúp đỡ mình!
Nhấp chuột vào đây để mở rộng...

Bạn áp dụng cái file các số nhiều này để làm gì vậy, có thể nói cho tôi và mọi người học hỏi ?
 
Sơn Mã đã viết:
Dạ, vâng đúng như ý hiểu của bạn rồi bạn ạ: Chỉ cần tìm nhóm số không trùng trong 100 số từ 00 đến 99 sao cho tất cả 400 cột đều chứa 1 trong các số đó, hoặc ít hơn 400 nhưng lấy số cột lớn nhất. (nếu tạo được hộp thông báo nhập số liệu cho các trường hợp trước khi chạy code: ví dụ như trường hợp tìm nhóm 80 số mình chỉ việc nhập 80 và chạy code để tìm, hoặc tìm nhóm 70 số chỉ việc nhập 70 và chạy code để tìm,..v.v.v.). Cảm ơn bạn giúp đỡ mình!
Nhấp chuột vào đây để mở rộng...
sheet ketqua là giá trị từng cột, cột cuối là là số giá trị không trùng
sheet1 là các giá trị chọn
Mã: 
Dim nn As Byte, C As Integer
Sub TimTrung()
Dim Dic As Object, DicKQ As Object, tmp As String, Arr(), Darr(), Sarr(), Tmparr, Kq(), KqCot()
Dim i As Integer, j As Integer, n As Integer, k As Integer, Dkq As Long, S As Integer, Lap As Integer
Set Dic = CreateObject("scripting.dictionary")
Set DicKQ = CreateObject("scripting.dictionary")
n = Sheets("DULIEU").UsedRange.Rows.Count - 1
C = 80:     nn = 100
Dkq = 1000 'khai báo Dkq, so dòng ket qua theo ý
Lap = 5000   'khai báo Lap > Dkq, càng lon chay càng lau và ít bo sot ket qua
Darr = Sheets("DULIEU").Range("A2:OJ" & n + 1).Value
ReDim Sarr(1 To n + 1, 1 To C * 5)


For j = 1 To C * 5
  For i = 1 To n
    If Darr(i, j) <> "" Then
      tmp = Darr(i, j) & "z" & j
      If Not Dic.exists(tmp) Then Dic.Add tmp, ""
    End If
  Next i
Next j


ReDim Kq(1 To Dkq, 1 To C * 5 + 1)
ReDim KqCot(1 To Dkq, 1 To C + 1)
n = 0
For S = 1 To Lap
  ReDim Sarr(1 To nn)
  Sarr = NN_80
  ReDim Arr(1 To 2, 1 To C * 5 + 1)
  k = 0
  For i = 1 To nn
    For j = 1 To C * 5
      If Arr(2, j) = "" Then
        tmp = Sarr(i) & "z" & j
        If Dic.exists(tmp) Then
          k = k + 1
          Arr(1, j) = Sarr(i)
          Arr(2, j) = j
        End If
      End If
    Next j
    If k = 400 Then
      tmp = SortArrToStr(Arr, "z", C * 5)
      If Not DicKQ.exists(tmp) Then
        DicKQ.Add tmp, ""
        n = n + 1
        Kq(n, C * 5 + 1) = i
        For j = 1 To C * 5
          Kq(n, j) = Arr(1, j)
        Next j
        tmp = SortArrToStr(Sarr, "z", C)
        Tmparr = Split(tmp, "z")
        For j = 1 To i
          KqCot(n, j) = Tmparr(j - 1)
        Next j
        KqCot(n, C + 1) = i
      End If
    End If
  Next i
  If n = Dkq Then Exit For
Next S
Sheets("KETQUA").Range("A2").Resize(10000, 400).ClearContents
Sheets("Sheet1").Range("A2").Resize(10000, 401).ClearContents
If n > 0 Then
  Sheets("KETQUA").Range("A2").Resize(n, C * 5 + 1) = Kq
  Sheets("Sheet1").Range("A2").Resize(n, C + 1) = KqCot
  Sheets("Sheet1").Activate
  Sheets("Sheet1").Range("D2").Resize(n, C + 1).Sort [s2], 1, Header:=xlNo
End If
Set Dic = Nothing:  Set DicKQ = Nothing
Erase Arr:    Erase Darr:   Erase Sarr:    Erase Kq:   Erase Tmparr:    Erase KqCot
End Sub


Function SortArrToStr(Tarr As Variant, Str As String, k As Integer) As String
  Dim ArrList As Object, Tmparr As Variant, j As Integer, tmp As String
  Set ArrList = CreateObject("System.Collections.ArrayList")
  For j = 1 To k
    If k = 400 Then
      tmp = Tarr(1, j)
    Else
      tmp = Tarr(j)
    End If
    ArrList.Add tmp
  Next j
  ArrList.Sort
  Tmparr = ArrList.ToArray
  SortArrToStr = Join(Tmparr, Str)
  Set ArrList = Nothing:    Erase Tmparr
End Function


Function NN_80() As Variant
Dim Dic As Object, Tarr(), tmp As Byte, k As Byte
Set Dic = CreateObject("scripting.dictionary")
ReDim Tarr(1 To nn)
  Do
    tmp = Int(100 * Rnd)
    If Not Dic.exists(tmp) Then
      k = k + 1:  Dic.Add tmp, ""
      Tarr(k) = tmp
    End If
  Loop Until k = nn
NN_80 = Tarr
Set Dic = Nothing:  Erase Tarr
End Function
 
HieuCD đã viết:
sheet ketqua là giá trị từng cột, cột cuối là là số giá trị không trùng
sheet1 là các giá trị chọn
Mã: 
Dim nn As Byte, C As Integer
Sub TimTrung()
Dim Dic As Object, DicKQ As Object, tmp As String, Arr(), Darr(), Sarr(), Tmparr, Kq(), KqCot()
Dim i As Integer, j As Integer, n As Integer, k As Integer, Dkq As Long, S As Integer, Lap As Integer
Set Dic = CreateObject("scripting.dictionary")
Set DicKQ = CreateObject("scripting.dictionary")
n = Sheets("DULIEU").UsedRange.Rows.Count - 1
C = 80:     nn = 100
Dkq = 1000 'khai báo Dkq, so dòng ket qua theo ý
Lap = 5000   'khai báo Lap > Dkq, càng lon chay càng lau và ít bo sot ket qua
Darr = Sheets("DULIEU").Range("A2:OJ" & n + 1).Value
ReDim Sarr(1 To n + 1, 1 To C * 5)


For j = 1 To C * 5
  For i = 1 To n
    If Darr(i, j) <> "" Then
      tmp = Darr(i, j) & "z" & j
      If Not Dic.exists(tmp) Then Dic.Add tmp, ""
    End If
  Next i
Next j


ReDim Kq(1 To Dkq, 1 To C * 5 + 1)
ReDim KqCot(1 To Dkq, 1 To C + 1)
n = 0
For S = 1 To Lap
  ReDim Sarr(1 To nn)
  Sarr = NN_80
  ReDim Arr(1 To 2, 1 To C * 5 + 1)
  k = 0
  For i = 1 To nn
    For j = 1 To C * 5
      If Arr(2, j) = "" Then
        tmp = Sarr(i) & "z" & j
        If Dic.exists(tmp) Then
          k = k + 1
          Arr(1, j) = Sarr(i)
          Arr(2, j) = j
        End If
      End If
    Next j
    If k = 400 Then
      tmp = SortArrToStr(Arr, "z", C * 5)
      If Not DicKQ.exists(tmp) Then
        DicKQ.Add tmp, ""
        n = n + 1
        Kq(n, C * 5 + 1) = i
        For j = 1 To C * 5
          Kq(n, j) = Arr(1, j)
        Next j
        tmp = SortArrToStr(Sarr, "z", C)
        Tmparr = Split(tmp, "z")
        For j = 1 To i
          KqCot(n, j) = Tmparr(j - 1)
        Next j
        KqCot(n, C + 1) = i
      End If
    End If
  Next i
  If n = Dkq Then Exit For
Next S
Sheets("KETQUA").Range("A2").Resize(10000, 400).ClearContents
Sheets("Sheet1").Range("A2").Resize(10000, 401).ClearContents
If n > 0 Then
  Sheets("KETQUA").Range("A2").Resize(n, C * 5 + 1) = Kq
  Sheets("Sheet1").Range("A2").Resize(n, C + 1) = KqCot
  Sheets("Sheet1").Activate
  Sheets("Sheet1").Range("D2").Resize(n, C + 1).Sort [s2], 1, Header:=xlNo
End If
Set Dic = Nothing:  Set DicKQ = Nothing
Erase Arr:    Erase Darr:   Erase Sarr:    Erase Kq:   Erase Tmparr:    Erase KqCot
End Sub


Function SortArrToStr(Tarr As Variant, Str As String, k As Integer) As String
  Dim ArrList As Object, Tmparr As Variant, j As Integer, tmp As String
  Set ArrList = CreateObject("System.Collections.ArrayList")
  For j = 1 To k
    If k = 400 Then
      tmp = Tarr(1, j)
    Else
      tmp = Tarr(j)
    End If
    ArrList.Add tmp
  Next j
  ArrList.Sort
  Tmparr = ArrList.ToArray
  SortArrToStr = Join(Tmparr, Str)
  Set ArrList = Nothing:    Erase Tmparr
End Function


Function NN_80() As Variant
Dim Dic As Object, Tarr(), tmp As Byte, k As Byte
Set Dic = CreateObject("scripting.dictionary")
ReDim Tarr(1 To nn)
  Do
    tmp = Int(100 * Rnd)
    If Not Dic.exists(tmp) Then
      k = k + 1:  Dic.Add tmp, ""
      Tarr(k) = tmp
    End If
  Loop Until k = nn
NN_80 = Tarr
Set Dic = Nothing:  Erase Tarr
End Function
Nhấp chuột vào đây để mở rộng...
Cảm ơn bạn. Mình kiểm tra code thì thấy cột kết quả cuối của sheet(KETQUA) không đúng với kiểm tra trong thực tế và các số chọn ở sheet1 có những số không có ở sheet(KETQUA). Bạn kiểm tra hộ giúp!
p/s: mình kiểm tra thử lấy 5 kết quả!
 

File đính kèm

Sơn Mã đã viết:
Cảm ơn bạn. Mình kiểm tra code thì thấy cột kết quả cuối của sheet(KETQUA) không đúng với kiểm tra trong thực tế và các số chọn ở sheet1 có những số không có ở sheet(KETQUA). Bạn kiểm tra hộ giúp!
p/s: mình kiểm tra thử lấy 5 kết quả!
Nhấp chuột vào đây để mở rộng...
bạn chỉnh lại 2 đoạn code
Mã: 
    If k = 400 Then
      tmp = SortArrToStr(Arr, "z", C * 5)
      If Not DicKQ.exists(tmp) Then
        DicKQ.Add tmp, ""
        n = n + 1
        Kq(n, C * 5 + 1) = i
        For j = 1 To C * 5
          Kq(n, j) = Arr(1, j)
        Next j
        Tmparr = Split(tmp, "z")
        KqCot(n, 1) = Tmparr(0)
        k = 1
        For j = 1 To 399
          If KqCot(n, k) <> Tmparr(j) Then
            k = k + 1
            KqCot(n, k) = Tmparr(j)
          End If
        Next j
        Kq(n, C * 5 + 1) = k
        KqCot(n, C + 1) = k
      End If
    End If
Mã: 
Function SortArrToStr(Tarr As Variant, Str As String, k As Integer) As String
  Dim ArrList As Object, Tmparr As Variant, j As Integer, tmp As String
  Set ArrList = CreateObject("System.Collections.ArrayList")
  For j = 1 To k
    tmp = Tarr(1, j)
    ArrList.Add tmp
  Next j
  ArrList.Sort
  Tmparr = ArrList.ToArray
  SortArrToStr = Join(Tmparr, Str)
  Set ArrList = Nothing:    Erase Tmparr
End Function
 
HieuCD đã viết:
bạn chỉnh lại 2 đoạn code
Mã: 
    If k = 400 Then
      tmp = SortArrToStr(Arr, "z", C * 5)
      If Not DicKQ.exists(tmp) Then
        DicKQ.Add tmp, ""
        n = n + 1
        Kq(n, C * 5 + 1) = i
        For j = 1 To C * 5
          Kq(n, j) = Arr(1, j)
        Next j
        Tmparr = Split(tmp, "z")
        KqCot(n, 1) = Tmparr(0)
        k = 1
        For j = 1 To 399
          If KqCot(n, k) <> Tmparr(j) Then
            k = k + 1
            KqCot(n, k) = Tmparr(j)
          End If
        Next j
        Kq(n, C * 5 + 1) = k
        KqCot(n, C + 1) = k
      End If
    End If
Mã: 
Function SortArrToStr(Tarr As Variant, Str As String, k As Integer) As String
  Dim ArrList As Object, Tmparr As Variant, j As Integer, tmp As String
  Set ArrList = CreateObject("System.Collections.ArrayList")
  For j = 1 To k
    tmp = Tarr(1, j)
    ArrList.Add tmp
  Next j
  ArrList.Sort
  Tmparr = ArrList.ToArray
  SortArrToStr = Join(Tmparr, Str)
  Set ArrList = Nothing:    Erase Tmparr
End Function
Nhấp chuột vào đây để mở rộng...
Dạ, vâng, cảm ơn bạn nhiều. Mình sửa lại code như bạn hướng dẫn. Phần sheet(KETQUA) thì chuẩn rồi ạ, nhưng phần sheet1 thì số giá trị chọn lại khác so với phần sheet(KETQUA). Mong Bạn xem giúp!
 

File đính kèm

Sơn Mã đã viết:
Dạ, vâng, cảm ơn bạn nhiều. Mình sửa lại code như bạn hướng dẫn. Phần sheet(KETQUA) thì chuẩn rồi ạ, nhưng phần sheet1 thì số giá trị chọn lại khác so với phần sheet(KETQUA). Mong Bạn xem giúp!
Nhấp chuột vào đây để mở rộng...
sheet1 đã sort theo thứ tự nên thứ tự dòng khác với sheet ketqua, mình tạo thêm cột cuối là thứ tự dòng tương ứng ở sheet ketqua, và đã bỏ lệnh sort, nếu muốn sort thì bỏ dấu nháy ' phía trước
Mã: 
Dim nn As Byte, C As Integer
Sub TimTrung()
Dim Dic As Object, DicKQ As Object, tmp As String, Arr(), Darr(), Sarr(), Tmparr, Kq(), KqCot()
Dim i As Integer, j As Integer, n As Integer, k As Integer, Dkq As Long, S As Integer, Lap As Integer
Set Dic = CreateObject("scripting.dictionary")
Set DicKQ = CreateObject("scripting.dictionary")
n = Sheets("DULIEU").UsedRange.Rows.Count - 1
C = 80:     nn = 100
Dkq = 5 '1000 'khai báo Dkq, so dòng ket qua theo ý
Lap = 5000   'khai báo Lap > Dkq, càng lon chay càng lau và ít bo sot ket qua
Darr = Sheets("DULIEU").Range("A2:OJ" & n + 1).Value
ReDim Sarr(1 To n + 1, 1 To C * 5)


For j = 1 To C * 5
  For i = 1 To n
    If Darr(i, j) <> "" Then
      tmp = Darr(i, j) & "z" & j
      If Not Dic.exists(tmp) Then Dic.Add tmp, ""
    End If
  Next i
Next j


ReDim Kq(1 To Dkq, 1 To C * 5 + 1)
[COLOR=#ff0000]ReDim KqCot(1 To Dkq, 1 To C + 2)[/COLOR]
n = 0
For S = 1 To Lap
  ReDim Sarr(1 To nn)
  Sarr = NN_80
  ReDim Arr(1 To 2, 1 To C * 5 + 1)
  k = 0
  For i = 1 To nn
    For j = 1 To C * 5
      If Arr(2, j) = "" Then
        tmp = Sarr(i) & "z" & j
        If Dic.exists(tmp) Then
          k = k + 1
          Arr(1, j) = Sarr(i)
          Arr(2, j) = j
        End If
      End If
    Next j


  If k = 400 Then
      tmp = SortArrToStr(Arr, "z", C * 5)
      If Not DicKQ.exists(tmp) Then
        DicKQ.Add tmp, ""
        n = n + 1
        Kq(n, C * 5 + 1) = i
        For j = 1 To C * 5
          Kq(n, j) = Arr(1, j)
        Next j
        Tmparr = Split(tmp, "z")
        KqCot(n, 1) = Tmparr(0)
        k = 1
        For j = 1 To 399
          If KqCot(n, k) <> Tmparr(j) Then
            k = k + 1
            KqCot(n, k) = Tmparr(j)
          End If
        Next j
        Kq(n, C * 5 + 1) = k
        KqCot(n, C + 1) = k
        [COLOR=#ff0000]KqCot(n, C + 2) = n + 1[/COLOR]
      End If
    End If
  
  Next i
  If n = Dkq Then Exit For
Next S
Sheets("KETQUA").Range("A2").Resize(10000, 400).ClearContents
Sheets("Sheet1").Range("A2").Resize(10000, 82).ClearContents
If n > 0 Then
  Sheets("KETQUA").Range("A2").Resize(n, C * 5 + 1) = Kq
  Sheets("Sheet1").Range("A2").Resize(n, C + 2) = KqCot
  Sheets("Sheet1").Activate
  [COLOR=#ff0000]'Sheets("Sheet1").Range("A2").Resize(n, C + 2).Sort [CC2], 1, Header:=xlNo[/COLOR]   'bo dau nhay dau dong neu muon sort tu thap den cao
End If
Set Dic = Nothing:  Set DicKQ = Nothing
Erase Arr:    Erase Darr:   Erase Sarr:    Erase Kq:   Erase Tmparr:    Erase KqCot
End Sub
 
HieuCD đã viết:
sheet1 đã sort theo thứ tự nên thứ tự dòng khác với sheet ketqua, mình tạo thêm cột cuối là thứ tự dòng tương ứng ở sheet ketqua, và đã bỏ lệnh sort, nếu muốn sort thì bỏ dấu nháy ' phía trước
Mã: 
Dim nn As Byte, C As Integer
Sub TimTrung()
Dim Dic As Object, DicKQ As Object, tmp As String, Arr(), Darr(), Sarr(), Tmparr, Kq(), KqCot()
Dim i As Integer, j As Integer, n As Integer, k As Integer, Dkq As Long, S As Integer, Lap As Integer
Set Dic = CreateObject("scripting.dictionary")
Set DicKQ = CreateObject("scripting.dictionary")
n = Sheets("DULIEU").UsedRange.Rows.Count - 1
C = 80:     nn = 100
Dkq = 5 '1000 'khai báo Dkq, so dòng ket qua theo ý
Lap = 5000   'khai báo Lap > Dkq, càng lon chay càng lau và ít bo sot ket qua
Darr = Sheets("DULIEU").Range("A2:OJ" & n + 1).Value
ReDim Sarr(1 To n + 1, 1 To C * 5)


For j = 1 To C * 5
  For i = 1 To n
    If Darr(i, j) <> "" Then
      tmp = Darr(i, j) & "z" & j
      If Not Dic.exists(tmp) Then Dic.Add tmp, ""
    End If
  Next i
Next j


ReDim Kq(1 To Dkq, 1 To C * 5 + 1)
[COLOR=#ff0000]ReDim KqCot(1 To Dkq, 1 To C + 2)[/COLOR]
n = 0
For S = 1 To Lap
  ReDim Sarr(1 To nn)
  Sarr = NN_80
  ReDim Arr(1 To 2, 1 To C * 5 + 1)
  k = 0
  For i = 1 To nn
    For j = 1 To C * 5
      If Arr(2, j) = "" Then
        tmp = Sarr(i) & "z" & j
        If Dic.exists(tmp) Then
          k = k + 1
          Arr(1, j) = Sarr(i)
          Arr(2, j) = j
        End If
      End If
    Next j


  If k = 400 Then
      tmp = [SIZE=4][B][COLOR=#ff8c00]SortArrToStr[/COLOR][/B][/SIZE](Arr, "z", C * 5)
      If Not DicKQ.exists(tmp) Then
        DicKQ.Add tmp, ""
        n = n + 1
        Kq(n, C * 5 + 1) = i
        For j = 1 To C * 5
          Kq(n, j) = Arr(1, j)
        Next j
        Tmparr = Split(tmp, "z")
        KqCot(n, 1) = Tmparr(0)
        k = 1
        For j = 1 To 399
          If KqCot(n, k) <> Tmparr(j) Then
            k = k + 1
            KqCot(n, k) = Tmparr(j)
          End If
        Next j
        Kq(n, C * 5 + 1) = k
        KqCot(n, C + 1) = k
        [COLOR=#ff0000]KqCot(n, C + 2) = n + 1[/COLOR]
      End If
    End If
  
  Next i
  If n = Dkq Then Exit For
Next S
Sheets("KETQUA").Range("A2").Resize(10000, 400).ClearContents
Sheets("Sheet1").Range("A2").Resize(10000, 82).ClearContents
If n > 0 Then
  Sheets("KETQUA").Range("A2").Resize(n, C * 5 + 1) = Kq
  Sheets("Sheet1").Range("A2").Resize(n, C + 2) = KqCot
  Sheets("Sheet1").Activate
  [COLOR=#ff0000]'Sheets("Sheet1").Range("A2").Resize(n, C + 2).Sort [CC2], 1, Header:=xlNo[/COLOR]   'bo dau nhay dau dong neu muon sort tu thap den cao
End If
Set Dic = Nothing:  Set DicKQ = Nothing
Erase Arr:    Erase Darr:   Erase Sarr:    Erase Kq:   Erase Tmparr:    Erase KqCot
End Sub
Nhấp chuột vào đây để mở rộng...
Cảm ơn bạn! Khi mình cho chạy code thấy báo lỗi: "Sub or Function not defined" và báo chỗ chữ vàng mình tô đậm. Bạn xem giúp ạ. Cảm ơn sự giúp đỡ của bạn nhiều!
 
Sơn Mã đã viết:
Cảm ơn bạn! Khi mình cho chạy code thấy báo lỗi: "Sub or Function not defined" và báo chỗ chữ vàng mình tô đậm. Bạn xem giúp ạ. Cảm ơn sự giúp đỡ của bạn nhiều!
Nhấp chuột vào đây để mở rộng...
hơi lạ, có 2 Function bạn có cho module không?
bạn nhận file
 

File đính kèm

HieuCD đã viết:
hơi lạ, có 2 Function bạn có cho module không?
bạn nhận file
Nhấp chuột vào đây để mở rộng...
Bạn ơi, có một điều lạ là mình chạy thử tất cả các trường hợp của các nhóm mà không có trường hợp nào của nhóm có chứa 1 giá trị nào từ 00 đến 09? Kết quả chỉ có các giá trị từ 10 trở lên? Bạn xem có sai xót ở đâu không ạ? Xin cảm ơn bạn!
 
Sơn Mã đã viết:
Bạn ơi, có một điều lạ là mình chạy thử tất cả các trường hợp của các nhóm mà không có trường hợp nào của nhóm có chứa 1 giá trị nào từ 00 đến 09? Kết quả chỉ có các giá trị từ 10 trở lên? Bạn xem có sai xót ở đâu không ạ? Xin cảm ơn bạn!
Nhấp chuột vào đây để mở rộng...
bạn chỉnh lại toàn bộ code
Mã: 
Dim nn As Byte, C As Integer
Sub TimTrung()
Dim Dic As Object, DicKQ As Object, tmp As String, Arr(), Darr(), Sarr(), Tmparr, Kq(), KqCot()
Dim i As Integer, j As Integer, n As Integer, k As Integer, Dkq As Long, S As Integer, Lap As Integer
Set Dic = CreateObject("scripting.dictionary")
Set DicKQ = CreateObject("scripting.dictionary")
n = Sheets("DULIEU").UsedRange.Rows.Count - 1
C = 80:     nn = 100
Dkq = 5 '1000 'khai báo Dkq, so dòng ket qua theo ý
Lap = 5000   'khai báo Lap > Dkq, càng lon chay càng lau và ít bo sot ket qua
Darr = Sheets("DULIEU").Range("A2:OJ" & n + 1).Value
ReDim Sarr(1 To n + 1, 1 To C * 5)


For j = 1 To C * 5
  For i = 1 To n
    If Darr(i, j) <> "" Then
      tmp = Val(Darr(i, j)) & "z" & j
      If Not Dic.exists(tmp) Then Dic.Add tmp, ""
    End If
  Next i
Next j


ReDim Kq(1 To Dkq, 1 To C * 5 + 1)
ReDim KqCot(1 To Dkq, 1 To C + 2)
n = 0
For S = 1 To Lap
  ReDim Sarr(1 To nn)
  Sarr = NN_80
  ReDim Arr(1 To 2, 1 To C * 5 + 1)
  k = 0
  For i = 1 To nn
    For j = 1 To C * 5
      If Arr(2, j) = "" Then
        tmp = Sarr(i) & "z" & j
        If Dic.exists(tmp) Then
          k = k + 1
          Arr(1, j) = Sarr(i)
          Arr(2, j) = j
        End If
      End If
    Next j


  If k = 400 Then
      tmp = SortArrToStr(Arr, "z", C * 5)
      If Not DicKQ.exists(tmp) Then
        DicKQ.Add tmp, ""
        n = n + 1
        Kq(n, C * 5 + 1) = i
        For j = 1 To C * 5
          Kq(n, j) = Arr(1, j)
        Next j
        Tmparr = Split(tmp, "z")
        KqCot(n, 1) = Tmparr(0)
        k = 1
        For j = 1 To 399
          If KqCot(n, k) <> Tmparr(j) Then
            k = k + 1
            KqCot(n, k) = Tmparr(j)
          End If
        Next j
        Kq(n, C * 5 + 1) = k
        KqCot(n, C + 1) = k
        KqCot(n, C + 2) = n + 1
      End If
    End If
  
  Next i
  If n = Dkq Then Exit For
Next S
Sheets("KETQUA").Range("A2").Resize(10000, 400).ClearContents
Sheets("Sheet1").Range("A2").Resize(10000, 82).ClearContents
If n > 0 Then
  Sheets("KETQUA").Range("A2").Resize(n, C * 5 + 1) = Kq
  Sheets("Sheet1").Range("A2").Resize(n, C + 2) = KqCot
  Sheets("Sheet1").Activate
  'Sheets("Sheet1").Range("A2").Resize(n, C + 2).Sort [CC2], 1, Header:=xlNo
End If
Set Dic = Nothing:  Set DicKQ = Nothing
Erase Arr:    Erase Darr:   Erase Sarr:    Erase Kq:   Erase Tmparr:    Erase KqCot
End Sub
  
Function SortArrToStr(Tarr As Variant, Str As String, k As Integer) As String
  Dim ArrList As Object, Tmparr As Variant, j As Integer, tmp As String
  Set ArrList = CreateObject("System.Collections.ArrayList")
  For j = 1 To k
    tmp = Format(Tarr(1, j), "00")
    ArrList.Add tmp
  Next j
  ArrList.Sort
  Tmparr = ArrList.ToArray
  SortArrToStr = Join(Tmparr, Str)
  Set ArrList = Nothing:    Erase Tmparr
End Function
 
Function NN_80() As Variant
Dim Dic As Object, Tarr(), tmp As Byte, k As Byte
Set Dic = CreateObject("scripting.dictionary")
ReDim Tarr(1 To nn)
  Do
    tmp = Int(100 * Rnd)
    If Not Dic.exists(tmp) Then
      k = k + 1:  Dic.Add tmp, ""
      Tarr(k) = tmp
    End If
  Loop Until k = nn
NN_80 = Tarr
Set Dic = Nothing:  Erase Tarr
End Function
 
Bạn ơi khi mình điểu chỉnh dữ liệu ở sheet(DULIEU) lên 1200 cột, thì mình chỉnh lại code như sau:
Dim nn As Byte, C As IntegerSub TimTrung()
Dim Dic As Object, DicKQ As Object, Tmp As String, Arr(), Darr(), Sarr(), Tmparr, Kq(), KqCot()
Dim i As Integer, j As Integer, n As Integer, k As Integer, Dkq As Long, S As Integer, Lap As Integer
Set Dic = CreateObject("scripting.dictionary")
Set DicKQ = CreateObject("scripting.dictionary")
n = Sheets("DULIEU").UsedRange.Rows.Count - 1
C = 80: nn = 100
Dkq = 500 '1000 'khai báo Dkq, so dòng ket qua theo ý
Lap = 20000 'khai báo Lap > Dkq, càng lon chay càng lau và ít bo sot ket qua
Darr = Sheets("DULIEU").Range("A2:ATD" & n + 1).Value 'ATD: la dia chi cot cuoi cung 1200
ReDim Sarr(1 To n + 1, 1 To C * 5)




For j = 1 To C * 5
For i = 1 To n
If Darr(i, j) <> "" Then
Tmp = Val(Darr(i, j)) & "z" & j
If Not Dic.exists(Tmp) Then Dic.Add Tmp, ""
End If
Next i
Next j




ReDim Kq(1 To Dkq, 1 To C * 5 + 1)
ReDim KqCot(1 To Dkq, 1 To C + 2)
n = 0
For S = 1 To Lap
ReDim Sarr(1 To nn)
Sarr = NN_80
ReDim Arr(1 To 2, 1 To C * 5 + 1)
k = 0
For i = 1 To nn
For j = 1 To C * 5
If Arr(2, j) = "" Then
Tmp = Sarr(i) & "z" & j
If Dic.exists(Tmp) Then
k = k + 1
Arr(1, j) = Sarr(i)
Arr(2, j) = j
End If
End If
Next j


If k = 1200 Then '1200 la so cot toan vung du lieu
Tmp = SortArrToStr(Arr, "z", C * 5)
If Not DicKQ.exists(Tmp) Then
DicKQ.Add Tmp, ""
n = n + 1
Kq(n, C * 5 + 1) = i
For j = 1 To C * 5
Kq(n, j) = Arr(1, j)
Next j
Tmparr = Split(Tmp, "z")
KqCot(n, 1) = Tmparr(0)
k = 1
For j = 1 To 1199 '1199 la so cot it hon 1
If KqCot(n, k) <> Tmparr(j) Then
k = k + 1
KqCot(n, k) = Tmparr(j)
End If
Next j
Kq(n, C * 5 + 1) = k
KqCot(n, C + 1) = k
KqCot(n, C + 2) = n + 1
End If
End If

Next i
If n = Dkq Then Exit For
Next S
Sheets("KETQUA").Range("A2").Resize(10000, 1200).ClearContents '1200 la so cot toan vung du lieu
Sheets("Sheet1").Range("A2").Resize(10000, 82).ClearContents
If n > 0 Then
Sheets("KETQUA").Range("A2").Resize(n, C * 5 + 1) = Kq
Sheets("Sheet1").Range("A2").Resize(n, C + 2) = KqCot
Sheets("Sheet1").Activate
'Sheets("Sheet1").Range("A2").Resize(n, C + 2).Sort [CC2], 1, Header:=xlNo
End If
Set Dic = Nothing: Set DicKQ = Nothing
Erase Arr: Erase Darr: Erase Sarr: Erase Kq: Erase Tmparr: Erase KqCot
End Sub

Function SortArrToStr(Tarr As Variant, Str As String, k As Integer) As String
Dim ArrList As Object, Tmparr As Variant, j As Integer, Tmp As String
Set ArrList = CreateObject("System.Collections.ArrayList")
For j = 1 To k
Tmp = Format(Tarr(1, j), "00")
ArrList.Add Tmp
Next j
ArrList.Sort
Tmparr = ArrList.ToArray
SortArrToStr = Join(Tmparr, Str)
Set ArrList = Nothing: Erase Tmparr
End Function

Function NN_80() As Variant
Dim Dic As Object, Tarr(), Tmp As Byte, k As Byte
Set Dic = CreateObject("scripting.dictionary")
ReDim Tarr(1 To nn)
Do
Tmp = Int(100 * Rnd)
If Not Dic.exists(Tmp) Then
k = k + 1: Dic.Add Tmp, ""
Tarr(k) = Tmp
End If
Loop Until k = nn
NN_80 = Tarr
Set Dic = Nothing: Erase Tarr
End Function
Nhấp chuột vào đây để mở rộng...

Và kết quả sau khi chạy code là báo lỗi "type mismath" và code báo vàng chỗ mình tô đậm. Bạn xem giúp lỗi đó là như thế nào và cách khắc phục ra sao? Xin cảm ơn bạn nhiều!
 
Sơn Mã đã viết:
Bạn ơi khi mình điểu chỉnh dữ liệu ở sheet(DULIEU) lên 1200 cột, thì mình chỉnh lại code như sau:


Và kết quả sau khi chạy code là báo lỗi "type mismath" và code báo vàng chỗ mình tô đậm. Bạn xem giúp lỗi đó là như thế nào và cách khắc phục ra sao? Xin cảm ơn bạn nhiều!
Nhấp chuột vào đây để mở rộng...
Mã: 
[COLOR=#000000][I]Set Dic = Nothing: Set DicKQ = Nothing[/I][/COLOR]
[COLOR=#000000][I]Erase Arr: Erase Darr: Erase Sarr: Erase Kq[/I][/COLOR][SIZE=4][COLOR=#000000][I][B][COLOR=#ff8c00]: Erase Tmparr[/COLOR][/B][/I][/COLOR][/SIZE][COLOR=#000000][I]: Erase KqCot
[/I][/COLOR]các lệnh trên dùng để xóa bộ nhớ đã chiếm dụng của code, có thì tốt, không có cũng được. bạn xóa chổ màu vàng đi
quan trọng là bạn phải tính lại tham số C*5, bạn thay bằng 1200 hoặc C*15
dữ liệu quá lớn và dạng chuổi, không biết bộ nhớ có chịu nổi không
 
HieuCD đã viết:
Mã: 
[COLOR=#000000][I]Set Dic = Nothing: Set DicKQ = Nothing[/I][/COLOR]
[COLOR=#000000][I]Erase Arr: Erase Darr: Erase Sarr: Erase Kq[/I][/COLOR][SIZE=4][COLOR=#000000][I][B][COLOR=#ff8c00]: Erase Tmparr[/COLOR][/B][/I][/COLOR][/SIZE][COLOR=#000000][I]: Erase KqCot[/I][/COLOR]
các lệnh trên dùng để xóa bộ nhớ đã chiếm dụng của code, có thì tốt, không có cũng được. bạn xóa chổ màu vàng đi
quan trọng là bạn phải tính lại tham số C*5, bạn thay bằng 1200 hoặc C*15
dữ liệu quá lớn và dạng chuổi, không biết bộ nhớ có chịu nổi không
Nhấp chuột vào đây để mở rộng...
Cảm ơn bạn rất nhiều. Trong code trên khi mình cho chạy code thì mình tìm ra được những nhóm kết quả có 20-30 giá trị là đã thoả mãn rồi. Nếu mình muốn tìm ra những nhóm mà phải có 80-90 giá trị mới lấy thì mình làm như thế nào? Cảm ơn bạn nhiều!
 
Sơn Mã đã viết:
Cảm ơn bạn rất nhiều. Trong code trên khi mình cho chạy code thì mình tìm ra được những nhóm kết quả có 20-30 giá trị là đã thoả mãn rồi. Nếu mình muốn tìm ra những nhóm mà phải có 80-90 giá trị mới lấy thì mình làm như thế nào? Cảm ơn bạn nhiều!
Nhấp chuột vào đây để mở rộng...
các số còn lại bạn cho số nào cũng được, miễn đừng trùng là được rồi
 
HieuCD đã viết:
các số còn lại bạn cho số nào cũng được, miễn đừng trùng là được rồi
Nhấp chuột vào đây để mở rộng...
Mong bạn có thể nói rõ được không ạ? ví dụ ở sheet(KETQUA): trong tất cả những trường hợp thoả mãn với số cột lớn nhất (các giá trị có thể trùng lặp) thì chỉ lấy trường hợp nào mà nhóm có 80 giá trị khác nhau (các giá trị trong nhóm cho phép được trùng lặp giữa các cột khác nhau) dán vào sheet(KETQUA) khi đó mình điều chỉnh code như thế nào ạ? Cảm ơn bạn!
 
giả sử có 20 số từ 0 đến 19 đã thỏa điều kiện, thì bạn chọn thêm 60 số trong dãy từ 20 đến 99 là được rồi, với dư liệu của bạn thì lúc nào cũng đúng
còn viết code để phân phối lại cho từng cột thì tuần sau mới rảnh
 
HieuCD đã viết:
giả sử có 20 số từ 0 đến 19 đã thỏa điều kiện, thì bạn chọn thêm 60 số trong dãy từ 20 đến 99 là được rồi, với dư liệu của bạn thì lúc nào cũng đúng
còn viết code để phân phối lại cho từng cột thì tuần sau mới rảnh
Nhấp chuột vào đây để mở rộng...
Vâng cảm ơn bạn. Mình sẽ đợi bạn viết lại code để phân phố lại cho từng cột! Đợi tin của bạn! Cảm ơn nhiều!
 
HieuCD đã viết:
bạn chạy code mới, khai báo số nguyên dương vào code để chạy theo ý bạn, chạy càng lâu thì bỏ sót càng ít
code chạy ngẫu nhiên nên mỗi lần chạy có thể kết quả khác nhau
đã loại trừ trùng lập
do ngẫu nhiên nên cũng không biết bỏ sót hay không
Mã: 
Sub Loc_Cot()
Dim Dic As Object, DicKQ As Object, tmp As String, Arr(), Darr(), Kq(), i As Integer, j As Integer, n As Integer
Dim C As Integer, k As Integer, dong As Integer, Dkq As Integer, jk As Integer, MinC As Integer, S As Byte, Lap As Byte
Set Dic = CreateObject("scripting.dictionary")
Set DicKQ = CreateObject("scripting.dictionary")
C = 100:     MinC = 150
k = Sheets("DULIEU").UsedRange.Rows.Count - 1
Dkq = 300 'khai báo Dkq, so dòng ket qua theo ý
Lap = 10   'khai báo Lap, càng lon chay càng lau và ít bo sot ket qua
Darr = Sheets("DULIEU").Range("A2", Sheets("DULIEU").Cells(k + 2, C)).Value
ReDim Arr(1 To 2, 1 To C + 1):  ReDim Kq(1 To Dkq, 1 To C + 1)
For j = 1 To C
    For i = 1 To k + 1
        If Darr(i, j) = "" Then
            Arr(2, j) = i - 1:       Exit For
        End If
    Next i
Next j
For S = 1 To Lap
  For k = 1 To 100
    For i = 1 To Arr(2, k)
        Dic.RemoveAll:    Arr(1, C + 1) = 0
        Dic.Add Darr(i, k), ""
        Arr(1, k) = Darr(i, k)
        Arr(1, C + 1) = Arr(1, C + 1) + 1
        For jk = 2 To 100
            j = jk:            If jk = k Then j = 1
            For n = 1 To Arr(2, j)
                If Not Dic.exists(Darr(n, j)) Then
                    Dic.Add Darr(n, j), ""
                    Arr(1, j) = Darr(n, j)
                    Arr(1, C + 1) = Arr(1, C + 1) + 1
                    Exit For
                End If
            Next n
        Next jk
        tmp = ""
        For j = 1 To C
          tmp = tmp & "z" & Arr(1, j)
        Next j
        If Not DicKQ.exists(tmp) Then
          DicKQ.Add tmp, ""
        Else
          GoTo Tiep
        End If
        If dong < Dkq Then
            dong = dong + 1
            For j = 1 To C + 1
                Kq(dong, j) = Arr(1, j)
            Next j
            If MinC > Arr(1, C + 1) Then MinC = Arr(1, C + 1)
        Else
            If Arr(1, C + 1) > MinC Then
              For n = 1 To Dkq
                If Kq(n, C + 1) = MinC Then
                  For j = 1 To C + 1
                    Kq(n, j) = Arr(1, j)
                  Next j
                  Exit For
                End If
              Next n
              MinC = 150
              For n = 1 To Dkq
                If MinC > Kq(n, C + 1) Then MinC = Kq(n, C + 1)
              Next n
            End If
        End If
Tiep:
    Next i
  Next k
  Darr = NgauNhien(Darr, Arr, C)
Next S
Sheets("KETQUA").Range("A2:CW2000").ClearContents
Sheets("KETQUA").Range("A2").Resize(Dkq, C + 1) = Kq
Set Dic = Nothing:    Set DicKQ = Nothing
End Sub


Function NgauNhien(Darr(), Arr(), C)
Dim Dic As Object, tmp As Integer, Sarr(), i As Integer, j As Integer, k As Integer
Set Dic = CreateObject("scripting.dictionary")
ReDim Sarr(1 To UBound(Darr), 1 To UBound(Darr, 2))
For j = 1 To C
    For i = 1 To k + 1
        If Darr(i, j) = "" Then
            Arr(2, j) = i - 1:       Exit For
        End If
    Next i
Next j
For j = 1 To C
  Dic.RemoveAll:  k = 0
  Do
    tmp = Int((Arr(2, j) * Rnd) + 1)
    If Not Dic.exists(tmp) Then
      k = k + 1:  Dic.Add tmp, ""
      Sarr(k, j) = Darr(tmp, j)
    End If
  Loop Until k = Arr(2, j)
Next j
NgauNhien = Sarr
Set Dic = Nothing
End Function
Nhấp chuột vào đây để mở rộng...
Bạn ơi, với code không lấy kết quả trùng ở bài #28, Hôm nay mình kiểm tra lại thêm lần nữa. Khi cho chạy với vòng lặp 250, lấy 30 kết quả đầu tiên thì mình thấy kết quả vẫn có giá trị trùng lặp: ví dụ dòng 2 giá trị 99 bị trùng 2 lần. Mong bạn xem giúp vì sao lại như vậy, mình gửi file minh hoạ cho bạn kiểm tra! Xin cảm ơn!
p/s: Ngoài ra khi mình muốn khai báo với vòng lặp lớn hơn 250 thì báo lỗi tràn ra: overflow!
 

File đính kèm

Lần chỉnh sửa cuối:
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

T
  • Question Question
Xin code VBA trả về tên tài khoản theo điều kiện
    • Chấp nhận
Trả lời
12
Đọc
383
VetMini
V
mucongnghenhat
lỗi đoạn văn bản bị đóng khung
Trả lời
0
Đọc
27
mucongnghenhat
mucongnghenhat
HeSanbi
  • Question Question
VBA Nâng cao: Hướng dẫn tạo biểu thức tìm kiếm với Regular Expression
    • Thích
    • Yêu thích
Trả lời
8
Đọc
585
nguyendang95
N
Uyên dương Hoya
Lỗi định dạng form chữ trong excel
Trả lời
1
Đọc
58
DeTong
D
ntnguyentam1907
Lấy bảng dữ liệu chứng khoán về excel
2
Trả lời
22
Đọc
3K
nguyendang95
N
PhanTuHuong
CHỌN VÀ SỬ DỤNG MÁY LỌC KHÔNG KHÍ
    • Cảm ơn
Trả lời
5
Đọc
756
hoangtuan.net
hoangtuan.net
huuthang_bd
Add-in DeleteVirusMacro - Xóa và ngăn chặn virus macro
    • Thích
    • Yêu thích
    • Chấp nhận
2
Trả lời
35
Đọc
13K
minhys1
M
ongke0711
  • Question Question
Tải hóa đơn điện tử (https://hoadondientu.gdt.gov.vn/) Excel Vba
    • Thích
    • Yêu thích
    • Cảm ơn
14 15 16
Trả lời
305
Đọc
21K
pkt.bacdau
pkt.bacdau
HONGVY91
Đếm số lượng 2 cột và đếm không trùng
Trả lời
2
Đọc
117
hoangtuaotrang_hp_vn
H
hanhlx88
Nhờ giúp file Excel báo lỗi: Excel cannot complete this task with available resources
Trả lời
3
Đọc
180
hanhlx88
hanhlx88
C
Trách nhiệm pháp lý của chi nhánh doanh nghiệp Việt Nam tại nước ngoài với Công ty tại Việt Nam
Trả lời
3
Đọc
107
VetMini
V
HeSanbi
  • Đã giải quyết
LocalizeXL v1.73 - Làm nổi bật ô đang chọn và cuộn trang tự động
    • Thích
    • Yêu thích
2 3 4
Trả lời
73
Đọc
10K
HeSanbi
HeSanbi
L
Folder chứa chương trình bị khóa bởi Lock folder
2
Trả lời
28
Đọc
25K
qthangvphaui
Q
P
Xin trợ giúp cách lập lịch trực tịnh tiến dần cho 1 nhóm người.
Trả lời
4
Đọc
142
phambahoang
P
N
Tính tổng với điều kiện gần đúng
Trả lời
3
Đọc
64
HUONGHCKT
H
Bùi Thúy Thúy
  • Question Question
Lấy dữ liệu thời tiết Accuweather để điền vào nhật ký thi công
2 3 4
Trả lời
63
Đọc
19K
Mutants Men
M
Anxseo
  • Đã khóa
Cách crack my excel
Trả lời
1
Đọc
175
HeSanbi
HeSanbi
phatnguyen7301
  • Question Question
Tạo âm thanh khi nhấn vào một phím
Trả lời
5
Đọc
245
yaaasoo01
Y
anhtuan1066
  • Question Question
Chèn hình vào cell bằng hàm tự tạo
    • Thích
    • Ngạc nhiên
10 11 12
Trả lời
235
Đọc
106K
XaNguyen
X
vc_đi chơi
Khóa Hoặc mã hóa File excel có độ bảo mật cao
    • Cảm ơn
    • Thích
Trả lời
3
Đọc
204
Hoangkhang01213
Hoangkhang01213
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

Đếm ngược thời gian

000
Ngày
00
Giờ
00
phút
00
giây
Chúc mừng năm mới.
Back
Top Bottom