Tìm nhóm số với số cột lớn nhất (1 người xem)

Sơn Mã · 9/1/17

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

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!

Gió Đông · 9/1/17

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!

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 ?

HieuCD · 9/1/17

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!

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

Sơn Mã · 10/1/17

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

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ả!

HieuCD · 10/1/17

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ả!

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

Sơn Mã · 11/1/17

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

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!

HieuCD · 11/1/17

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!

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

Sơn Mã · 11/1/17

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

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!

HieuCD · 11/1/17

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!

hơi lạ, có 2 Function bạn có cho module không?
bạn nhận file

Gió Đông · 11/1/17

winvista đã viết:
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ã cho câu trả lời?

Sơn Mã · 12/1/17

HieuCD đã viết:
hơi lạ, có 2 Function bạn có cho module không?
bạn nhận file

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!

HieuCD · 12/1/17

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!

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

Sơn Mã · 13/1/17

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

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!

HieuCD · 13/1/17

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!

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

Sơn Mã · 13/1/17

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

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!

HieuCD · 13/1/17

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!

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

Sơn Mã · 13/1/17

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

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!

HieuCD · 13/1/17

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

Sơn Mã · 13/1/17

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

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!

Sơn Mã · 15/1/17

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

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!

Tìm nhóm số với số cột lớn nhất (1 người xem)

Người dùng đang xem chủ đề này

Thành viên hoạt động

BĂNG TRÔI

Chuyên gia GPE

Thành viên hoạt động

File đính kèm

Chuyên gia GPE

Thành viên hoạt động

File đính kèm

Chuyên gia GPE

Thành viên hoạt động

Chuyên gia GPE

File đính kèm

BĂNG TRÔI

Thành viên hoạt động

Chuyên gia GPE

Thành viên hoạt động

Chuyên gia GPE

Thành viên hoạt động

Chuyên gia GPE

Thành viên hoạt động

Chuyên gia GPE

Thành viên hoạt động

Thành viên hoạt động

File đính kèm

Sinh nhật lần 19 GPE