Nhờ giúp code hoán đổi ngẫu nhiên dữ liệu trong một vùng

Liên hệ QC

titanic20072007

Thành viên thường trực
Tham gia
10/7/07
Bài viết
213
Được thích
8
Nghề nghiệp
Giáo viên
Chào các bạn. Mình gặp tình huống chưa giải quyết được nhờ mọi người giúp:
Có 1 bảng dữ liệu được tạo ngẫu nhiên (trong tệp đính kèm). Mình muốn hoán đổi ngẫu nhiên các dữ liệu đó (các cột từ A1 đến A14) sao cho các ô chứa dữ liệu trên một đơn vị không lặp lại so với dữ liệu trước của đơn vị đó. Số lượng ô có dữ liệu của một đơn vị không thay đổi sau khi thực hiện hoán. Mình có tệp dữ liệu kèm theo. Mong các bạn giúp code để làm việc này. Cảm ơn các bạn.
 

File đính kèm

  • Du lieu.xls
    36.5 KB · Đọc: 27
Chào các bạn. Mình gặp tình huống chưa giải quyết được nhờ mọi người giúp:
Có 1 bảng dữ liệu được tạo ngẫu nhiên (trong tệp đính kèm). Mình muốn hoán đổi ngẫu nhiên các dữ liệu đó (các cột từ A1 đến A14) sao cho các ô chứa dữ liệu trên một đơn vị không lặp lại so với dữ liệu trước của đơn vị đó. Số lượng ô có dữ liệu của một đơn vị không thay đổi sau khi thực hiện hoán. Mình có tệp dữ liệu kèm theo. Mong các bạn giúp code để làm việc này. Cảm ơn các bạn.
Bạn chạy thử code này:
Mã:
Sub a()
Dim arr, dic As Object, i As Long, j As Long, nr As Long, ndic As Long, arrres
Set dic = CreateObject("scripting.dictionary")
arr = [b3:p26]: ReDim arrres(1 To UBound(arr), 1 To UBound(arr, 2))
With dic
    For i = 1 To UBound(arr)
        For j = 2 To UBound(arr, 2)
            If Not .exists(arr(i, j)) And arr(i, j) <> Empty Then .Add arr(i, j), ""
        Next
    Next
    Randomize
    For i = 1 To UBound(arr)
        For j = 2 To arr(i, 1) + 1
           arrres(i, j) = .keys()(Int(Rnd() * .Count))
           .Remove arrres(i, j)
        Next
    Next
End With
[b33].Resize(UBound(arr), UBound(arr, 2)) = arrres
End Sub
 
Upvote 0
Bạn chạy thử code này:
Mã:
Sub a()
Dim arr, dic As Object, i As Long, j As Long, nr As Long, ndic As Long, arrres
Set dic = CreateObject("scripting.dictionary")
arr = [b3:p26]: ReDim arrres(1 To UBound(arr), 1 To UBound(arr, 2))
With dic
    For i = 1 To UBound(arr)
        For j = 2 To UBound(arr, 2)
            If Not .exists(arr(i, j)) And arr(i, j) <> Empty Then .Add arr(i, j), ""
        Next
    Next
    Randomize
    For i = 1 To UBound(arr)
        For j = 2 To arr(i, 1) + 1
           arrres(i, j) = .keys()(Int(Rnd() * .Count))
           .Remove arrres(i, j)
        Next
    Next
End With
[b33].Resize(UBound(arr), UBound(arr, 2)) = arrres
End Sub
Cảm ơn excel_lv1.5
Mình chạy thử thấy dữ liệu của cùng một đơn vị sau khi hoán ngẫu nhiên vẫn trùng với một trong những dữ liệu cũ (mình gửi tệp đính kèm). Bạn xử lý giúp mình vấn đề đó nhé.
 

File đính kèm

  • Du lieu 1.xls
    59.5 KB · Đọc: 9
Upvote 0
Cảm ơn excel_lv1.5
Mình chạy thử thấy dữ liệu của cùng một đơn vị sau khi hoán ngẫu nhiên vẫn trùng với một trong những dữ liệu cũ (mình gửi tệp đính kèm). Bạn xử lý giúp mình vấn đề đó nhé.
Code này chạy random nên mỗi lần chạy sẽ cho kết quả khác nhau, khả năng trùng với trường hợp cũ là khá thấp, nhưng cũng chỉnh lại theo ý bạn, bạn chạy lại code:
Mã:
Sub a()
Dim arr, dic As Object, i As Long, j As Long, nr As Long, ndic As Long, arrres
Set dic = CreateObject("scripting.dictionary")
arr = [b3:p26]: ReDim arrres(1 To UBound(arr), 1 To UBound(arr, 2))
With dic
    For i = 1 To UBound(arr)
        For j = 2 To UBound(arr, 2)
            If Not .exists(arr(i, j)) And arr(i, j) <> Empty Then .Add arr(i, j), ""
        Next
    Next
    Randomize
    For i = 1 To UBound(arr)
        For j = 2 To arr(i, 1) + 1
retu:
           arrres(i, j) = .keys()(Int(Rnd() * .Count))
           If arr(i, j) = arrres(i, j) Then GoTo retu
           .Remove arrres(i, j)
        Next
    Next
End With
[b33].Resize(UBound(arr), UBound(arr, 2)) = arrres
End Sub
 
Upvote 0
Chào các bạn. Mình gặp tình huống chưa giải quyết được nhờ mọi người giúp:
Có 1 bảng dữ liệu được tạo ngẫu nhiên (trong tệp đính kèm). Mình muốn hoán đổi ngẫu nhiên các dữ liệu đó (các cột từ A1 đến A14) sao cho các ô chứa dữ liệu trên một đơn vị không lặp lại so với dữ liệu trước của đơn vị đó. Số lượng ô có dữ liệu của một đơn vị không thay đổi sau khi thực hiện hoán. Mình có tệp dữ liệu kèm theo. Mong các bạn giúp code để làm việc này. Cảm ơn các bạn.
Chạy code
Mã:
Sub XYZ()
  Dim sArr(), Res(), tmp$, tmp2$
  Dim i&, r&, r2&, j&, c&, k&, sRow&, sCol&
  sArr = Range("B3:P26").Value
  sRow = UBound(sArr): sCol = UBound(sArr, 2)
  ReDim Res(1 To sRow, 1 To sCol)
  With CreateObject("scripting.dictionary")
    For i = 1 To sRow
      For j = 2 To sCol
        If sArr(i, j) <> Empty Then
          .Add sArr(i, j), i
          N = N + 1
        End If
      Next j
    Next i
    Randomize
    For i = 1 To sRow
      For j = 2 To sArr(i, 1) + 1
        k = 0
        Do
          k = k + 1
          If k = 100 Then
            r2 = .Item(tmp)
            Do
              r = Int(Rnd() * sRow + 1)
            Loop Until r < i And r <> r2
            Do
              c = Int(Rnd() * sArr(r, 1) + 2)
              tmp2 = Res(r, c)
            Loop Until .Item(tmp2) <> i
            Res(r, c) = tmp
            tmp = tmp2
          End If
          tmp = .keys()(Int(Rnd() * .Count))
        Loop Until .Item(tmp) <> i
        Res(i, j) = tmp
        .Remove tmp
      Next j
    Next i
  End With
  Range("B33").Resize(sRow, sCol) = Res
End Sub
 
Upvote 0
Code này chạy random nên mỗi lần chạy sẽ cho kết quả khác nhau, khả năng trùng với trường hợp cũ là khá thấp, nhưng cũng chỉnh lại theo ý bạn, bạn chạy lại code:
Mã:
Sub a()
Dim arr, dic As Object, i As Long, j As Long, nr As Long, ndic As Long, arrres
Set dic = CreateObject("scripting.dictionary")
arr = [b3:p26]: ReDim arrres(1 To UBound(arr), 1 To UBound(arr, 2))
With dic
    For i = 1 To UBound(arr)
        For j = 2 To UBound(arr, 2)
            If Not .exists(arr(i, j)) And arr(i, j) <> Empty Then .Add arr(i, j), ""
        Next
    Next
    Randomize
    For i = 1 To UBound(arr)
        For j = 2 To arr(i, 1) + 1
retu:
           arrres(i, j) = .keys()(Int(Rnd() * .Count))
           If arr(i, j) = arrres(i, j) Then GoTo retu
           .Remove arrres(i, j)
        Next
    Next
End With
[b33].Resize(UBound(arr), UBound(arr, 2)) = arrres
End Sub
Vẫn trùng excel_lv1.5 ơi. Tuy nhiên tỷ lệ trùng có vẻ ít hơn. Bạn nghiên cứu xem có cách nào triệt để hơn không?
Bài đã được tự động gộp:

Chạy code
Mã:
Sub XYZ()
  Dim sArr(), Res(), tmp$, tmp2$
  Dim i&, r&, r2&, j&, c&, k&, sRow&, sCol&
  sArr = Range("B3:P26").Value
  sRow = UBound(sArr): sCol = UBound(sArr, 2)
  ReDim Res(1 To sRow, 1 To sCol)
  With CreateObject("scripting.dictionary")
    For i = 1 To sRow
      For j = 2 To sCol
        If sArr(i, j) <> Empty Then
          .Add sArr(i, j), i
          N = N + 1
        End If
      Next j
    Next i
    Randomize
    For i = 1 To sRow
      For j = 2 To sArr(i, 1) + 1
        k = 0
        Do
          k = k + 1
          If k = 100 Then
            r2 = .Item(tmp)
            Do
              r = Int(Rnd() * sRow + 1)
            Loop Until r < i And r <> r2
            Do
              c = Int(Rnd() * sArr(r, 1) + 2)
              tmp2 = Res(r, c)
            Loop Until .Item(tmp2) <> i
            Res(r, c) = tmp
            tmp = tmp2
          End If
          tmp = .keys()(Int(Rnd() * .Count))
        Loop Until .Item(tmp) <> i
        Res(i, j) = tmp
        .Remove tmp
      Next j
    Next i
  End With
  Range("B33").Resize(sRow, sCol) = Res
End Sub
Cảm ơn HieuCD
Code chạy không còn trùng nữa nhưng khi chạy lại xóa mất dữ liệu ở cột B - Số lượng A trên bảng sau hoán chuyển. Bạn có thể chỉ mình điều chỉnh lại được không?
 

File đính kèm

  • Du lieu 2.xls
    64 KB · Đọc: 3
Upvote 0
Vẫn trùng excel_lv1.5 ơi. Tuy nhiên tỷ lệ trùng có vẻ ít hơn. Bạn nghiên cứu xem có cách nào triệt để hơn không?
Tôi không đọc kĩ chỗ không trùng đơn vị, bạn chạy lại code:
Mã:
Sub a()
Dim arr, dic As Object, i As Long, j As Long, n As Long, arrres, wf As WorksheetFunction
arr = [b3:p26]: ReDim arrres(1 To UBound(arr), 1 To UBound(arr, 2)): Set wf = WorksheetFunction
rt2:
Set dic = CreateObject("scripting.dictionary")
With dic
    For i = 1 To UBound(arr)
        For j = 2 To UBound(arr, 2)
            If Not .exists(arr(i, j)) And arr(i, j) <> Empty Then .Add arr(i, j), ""
        Next
    Next
    Randomize
    For i = 1 To UBound(arr)
        For j = 2 To arr(i, 1) + 1
           n = 0: arrres(i, 1) = arr(i, 1)
rt:
           n = n + 1: If n > 20 Then GoTo rt2
           arrres(i, j) = .keys()(Int(Rnd() * .Count))
           If InStr(Join(wf.Transpose(wf.Transpose(Range([c2].Offset(i), [p2].Offset(i)))), "|") & "|", arrres(i, j) & "|") Then GoTo rt
           .Remove arrres(i, j)
        Next
    Next
End With
[b33].Resize(UBound(arr), UBound(arr, 2)) = arrres
End Sub
 
Lần chỉnh sửa cuối:
Upvote 0
Vẫn trùng excel_lv1.5 ơi. Tuy nhiên tỷ lệ trùng có vẻ ít hơn. Bạn nghiên cứu xem có cách nào triệt để hơn không?
Bài đã được tự động gộp:


Cảm ơn HieuCD
Code chạy không còn trùng nữa nhưng khi chạy lại xóa mất dữ liệu ở cột B - Số lượng A trên bảng sau hoán chuyển. Bạn có thể chỉ mình điều chỉnh lại được không?
Thêm cột số lượng
Mã:
Sub XYZ()
  Dim sArr(), Res(), tmp$, tmp2$
  Dim i&, r&, r2&, j&, c&, k&, sRow&, sCol&
  sArr = Range("B3:P26").Value
  sRow = UBound(sArr): sCol = UBound(sArr, 2)
  ReDim Res(1 To sRow, 1 To sCol)
  With CreateObject("scripting.dictionary")
    For i = 1 To sRow
      Res(i, 1) = sArr(i, 1)
      For j = 2 To sCol
        If sArr(i, j) <> Empty Then
          .Add sArr(i, j), i
        End If
      Next j
    Next i
    Randomize
    For i = 1 To sRow
      For j = 2 To sArr(i, 1) + 1
        k = 0
        Do
          k = k + 1
          If k = 100 Then
            r2 = .Item(tmp)
            Do
              r = Int(Rnd() * sRow + 1)
            Loop Until r < i And r <> r2
            Do
              c = Int(Rnd() * sArr(r, 1) + 2)
              tmp2 = Res(r, c)
            Loop Until .Item(tmp2) <> i
            Res(r, c) = tmp
            tmp = tmp2
          End If
          tmp = .keys()(Int(Rnd() * .Count))
        Loop Until .Item(tmp) <> i
        Res(i, j) = tmp
        .Remove tmp
      Next j
    Next i
  End With
  Range("B33").Resize(sRow, sCol) = Res
End Sub
 
Upvote 0
Tôi không đọc kĩ chỗ không trùng đơn vị, bạn chạy lại code:
Mã:
Sub a()
Dim arr, dic As Object, i As Long, j As Long, n As Long, arrres, wf As WorksheetFunction
arr = [b3:p26]: ReDim arrres(1 To UBound(arr), 1 To UBound(arr, 2)): Set wf = WorksheetFunction
rt2:
Set dic = CreateObject("scripting.dictionary")
With dic
    For i = 1 To UBound(arr)
        For j = 2 To UBound(arr, 2)
            If Not .exists(arr(i, j)) And arr(i, j) <> Empty Then .Add arr(i, j), ""
        Next
    Next
    Randomize
    For i = 1 To UBound(arr)
        For j = 2 To arr(i, 1) + 1
           n = 0: arrres(i, 1) = arr(i, 1)
rt:
           n = n + 1: If n > 20 Then GoTo rt2
           arrres(i, j) = .keys()(Int(Rnd() * .Count))
           If InStr(Join(wf.Transpose(wf.Transpose(Range([c2].Offset(i), [p2].Offset(i)))), "|") & "|", arrres(i, j) & "|") Then GoTo rt
           .Remove arrres(i, j)
        Next
    Next
End With
[b33].Resize(UBound(arr), UBound(arr, 2)) = arrres
End Sub
Bản có thể chỉnh để không xóa mất cột Số lượng A ở bảng sau hoán chuyển được không?
 
Upvote 0
Thêm cột số lượng
Mã:
Sub XYZ()
  Dim sArr(), Res(), tmp$, tmp2$
  Dim i&, r&, r2&, j&, c&, k&, sRow&, sCol&
  sArr = Range("B3:P26").Value
  sRow = UBound(sArr): sCol = UBound(sArr, 2)
  ReDim Res(1 To sRow, 1 To sCol)
  With CreateObject("scripting.dictionary")
    For i = 1 To sRow
      Res(i, 1) = sArr(i, 1)
      For j = 2 To sCol
        If sArr(i, j) <> Empty Then
          .Add sArr(i, j), i
        End If
      Next j
    Next i
    Randomize
    For i = 1 To sRow
      For j = 2 To sArr(i, 1) + 1
        k = 0
        Do
          k = k + 1
          If k = 100 Then
            r2 = .Item(tmp)
            Do
              r = Int(Rnd() * sRow + 1)
            Loop Until r < i And r <> r2
            Do
              c = Int(Rnd() * sArr(r, 1) + 2)
              tmp2 = Res(r, c)
            Loop Until .Item(tmp2) <> i
            Res(r, c) = tmp
            tmp = tmp2
          End If
          tmp = .keys()(Int(Rnd() * .Count))
        Loop Until .Item(tmp) <> i
        Res(i, j) = tmp
        .Remove tmp
      Next j
    Next i
  End With
  Range("B33").Resize(sRow, sCol) = Res
End Sub
Khi mình test với ít dữ liệu thì xuất hiện nhiều lỗi, số lỗi tỷ lệ nghịch với dữ liệu (tệp đính kèm) bạn có thể chỉnh lại giúp mình được không?
 

File đính kèm

  • Du lieu 2.xls
    52.5 KB · Đọc: 7
Upvote 0
Khi mình test với ít dữ liệu thì xuất hiện nhiều lỗi, số lỗi tỷ lệ nghịch với dữ liệu (tệp đính kèm) bạn có thể chỉnh lại giúp mình được không?
Chỉnh lại code
Mã:
Sub XYZ()
  Dim sArr(), Res(), tmp$, Dic As Object, rowDic As Object
  Dim i&, r&, j&, c&, k&, sRow&, sCol&

  sArr = Range("B3:P26").Value
  sRow = UBound(sArr): sCol = UBound(sArr, 2)
  ReDim Res(1 To sRow, 1 To sCol)
  Set Dic = CreateObject("scripting.dictionary")
  Set rowDic = CreateObject("scripting.dictionary")

  Randomize
  For i = 1 To sRow
    Res(i, 1) = sArr(i, 1)
    If sArr(i, 1) > 0 Then
      For j = 2 To sCol
        If sArr(i, j) <> Empty Then
          Dic.Add sArr(i, j), i
          rowDic.Add sArr(i, j), i
        End If
      Next j
    End If
  Next i

  For i = 1 To sRow
    If sArr(i, 1) > 0 Then
      For j = 2 To sArr(i, 1) + 1
        k = 0
        Do
          tmp = Dic.keys()(Int(Rnd() * Dic.Count))
          r = rowDic.Item(tmp)
          If r = i Then k = k + 1
          If k = 50 Then
            Do
              r = Int(Rnd() * (i - 1)) + 1
              If sArr(r, 1) > 0 Then
                For c = 2 To sArr(r, 1) + 1
                  If rowDic.Item(Res(r, c)) <> i Then Exit For
                Next c
                If c <> sArr(r, 1) + 2 Then
                  Res(i, j) = Res(r, c):    Res(r, c) = tmp
                  Exit Do
                End If
              End If
            Loop Until k = 51
          End If
        Loop Until r <> i
        If Res(i, j) = Empty Then Res(i, j) = tmp
        Dic.Remove tmp
      Next j
    End If
  Next i
  Range("S3").Resize(sRow, sCol) = Res
  Set Dic = Nothing: Set rowDic = Nothing
End Sub
 
Upvote 0
Chỉnh lại code
Mã:
Sub XYZ()
  Dim sArr(), Res(), tmp$, Dic As Object, rowDic As Object
  Dim i&, r&, j&, c&, k&, sRow&, sCol&

  sArr = Range("B3:P26").Value
  sRow = UBound(sArr): sCol = UBound(sArr, 2)
  ReDim Res(1 To sRow, 1 To sCol)
  Set Dic = CreateObject("scripting.dictionary")
  Set rowDic = CreateObject("scripting.dictionary")

  Randomize
  For i = 1 To sRow
    Res(i, 1) = sArr(i, 1)
    If sArr(i, 1) > 0 Then
      For j = 2 To sCol
        If sArr(i, j) <> Empty Then
          Dic.Add sArr(i, j), i
          rowDic.Add sArr(i, j), i
        End If
      Next j
    End If
  Next i

  For i = 1 To sRow
    If sArr(i, 1) > 0 Then
      For j = 2 To sArr(i, 1) + 1
        k = 0
        Do
          tmp = Dic.keys()(Int(Rnd() * Dic.Count))
          r = rowDic.Item(tmp)
          If r = i Then k = k + 1
          If k = 50 Then
            Do
              r = Int(Rnd() * (i - 1)) + 1
              If sArr(r, 1) > 0 Then
                For c = 2 To sArr(r, 1) + 1
                  If rowDic.Item(Res(r, c)) <> i Then Exit For
                Next c
                If c <> sArr(r, 1) + 2 Then
                  Res(i, j) = Res(r, c):    Res(r, c) = tmp
                  Exit Do
                End If
              End If
            Loop Until k = 51
          End If
        Loop Until r <> i
        If Res(i, j) = Empty Then Res(i, j) = tmp
        Dic.Remove tmp
      Next j
    End If
  Next i
  Range("S3").Resize(sRow, sCol) = Res
  Set Dic = Nothing: Set rowDic = Nothing
End Sub
Cảm ơn bạn nhiều. Code chạy đã chuẩn rồi.
 
Upvote 0
Ah, tôi đã sửa rồi, bạn copy code lại rồi chạy lại.
Mình chạy code của bạn với vùng DL gốc và vùng chứa KQ trên cùng sheet thì code cho KQ chính xác. Nhưng khi mình thử chuyển DL gốc sang sheet khác thì không thể định vị (truyền đường dẫn) được vùng DL gốc vào lệnh If InStr(Join(wf.Transpose(wf.Transpose(Range([c2].Offset(i), [p2].Offset(i)))), "|") & "|", arrres(i, j) & "|") Then GoTo rt
được để so sánh KQ với DL gốc nhằm loại bỏ các trường hợp trùng, dẫn đến KQ trong trường hợp này vẫn còn giá trị bị trùng. Các bạn có thể HD mình trong trường hợp này không?
 

File đính kèm

  • Du lieu 3.xls
    141.5 KB · Đọc: 1
Lần chỉnh sửa cuối:
Upvote 0
Chỉnh lại code
Mã:
Sub XYZ()
  Dim sArr(), Res(), tmp$, Dic As Object, rowDic As Object
  Dim i&, r&, j&, c&, k&, sRow&, sCol&

  sArr = Range("B3:P26").Value
  sRow = UBound(sArr): sCol = UBound(sArr, 2)
  ReDim Res(1 To sRow, 1 To sCol)
  Set Dic = CreateObject("scripting.dictionary")
  Set rowDic = CreateObject("scripting.dictionary")

  Randomize
  For i = 1 To sRow
    Res(i, 1) = sArr(i, 1)
    If sArr(i, 1) > 0 Then
      For j = 2 To sCol
        If sArr(i, j) <> Empty Then
          Dic.Add sArr(i, j), i
          rowDic.Add sArr(i, j), i
        End If
      Next j
    End If
  Next i

  For i = 1 To sRow
    If sArr(i, 1) > 0 Then
      For j = 2 To sArr(i, 1) + 1
        k = 0
        Do
          tmp = Dic.keys()(Int(Rnd() * Dic.Count))
          r = rowDic.Item(tmp)
          If r = i Then k = k + 1
          If k = 50 Then
            Do
              r = Int(Rnd() * (i - 1)) + 1
              If sArr(r, 1) > 0 Then
                For c = 2 To sArr(r, 1) + 1
                  If rowDic.Item(Res(r, c)) <> i Then Exit For
                Next c
                If c <> sArr(r, 1) + 2 Then
                  Res(i, j) = Res(r, c):    Res(r, c) = tmp
                  Exit Do
                End If
              End If
            Loop Until k = 51
          End If
        Loop Until r <> i
        If Res(i, j) = Empty Then Res(i, j) = tmp
        Dic.Remove tmp
      Next j
    End If
  Next i
  Range("S3").Resize(sRow, sCol) = Res
  Set Dic = Nothing: Set rowDic = Nothing
End Sub
Code cho ra KQ chuẩn rồi, nhưng khi mình chèn mã đơn vị vào rồi chạy thì ở bảng KQ đưa ra trong một đơn vị (dòng) có khi xuất hiện hai hoặc ba giá trị của cùng một đơn vị cũ (đầu cùng mã) Hieu CD có thể chỉnh thêm giúp mình để sao cho mỗi dòng ở bảng kết quả các giá trị của nó không có từ 2 giá trị cùng đơn vị cũ không? Cảm ơn bạn nhiều.
 

File đính kèm

  • Du lieu 3.xls
    62.5 KB · Đọc: 10
Upvote 0
Code cho ra KQ chuẩn rồi, nhưng khi mình chèn mã đơn vị vào rồi chạy thì ở bảng KQ đưa ra trong một đơn vị (dòng) có khi xuất hiện hai hoặc ba giá trị của cùng một đơn vị cũ (đầu cùng mã) Hieu CD có thể chỉnh thêm giúp mình để sao cho mỗi dòng ở bảng kết quả các giá trị của nó không có từ 2 giá trị cùng đơn vị cũ không? Cảm ơn bạn nhiều.
"10.A4.7" đầu mã là "10" hay là "10.A4" ?
1 dòng dữ liệu gốc, đầu mã luôn giống nhau ?
Nêu rỏ tất cả khả năng của dữ liệu và yêu cầu, chỉ viết code thêm 1 lần
 
Upvote 0
"10.A4.7" đầu mã là "10" hay là "10.A4" ?
1 dòng dữ liệu gốc, đầu mã luôn giống nhau ?
Nêu rỏ tất cả khả năng của dữ liệu và yêu cầu, chỉ viết code thêm 1 lần
Nếu "10.A4.7" đầu mã là "10" bạn à. Đúng rồi một dòng dữ liệu gốc thì đầu mã giống nhau đều là một số có 2 chữ số. Chính là mã của đơn vị ứng với dòng mà giá trí đó ở trong bảng dữ liệu gốc. Bạn chỉnh giúp mình thêm sao cho sau khi hoán chuyển thì giá trị của một ô bất không đc ở lại dòng cũ (bạn đã làm được rồi) và trong cùng một dòng mới không có từ hai mã có cùng đầu mã giống nhau. Cảm ơn bạn nhiều.
 
Lần chỉnh sửa cuối:
Upvote 0
Nếu "10.A4.7" đầu mã là "10" bạn à. Đúng rồi một dòng dữ liệu gốc thì đầu mã giống nhau đều là một số có 2 chữ số. Chính là mã của đơn vị ứng với dòng mà giá trí đó ở trong bảng dữ liệu gốc. Bạn chỉnh giúp mình thêm sao cho sau khi hoán chuyển thì giá trị của một ô bất không đc ở lại dòng cũ (bạn đã làm được rồi) và trong cùng một dòng mới không có từ hai mã có cùng đầu mã giống nhau. Cảm ơn bạn nhiều.
Kiểm tra lại kết quả
Mã:
Sub XYZ()
  Dim sArr(), a(), uni, S, Res(), tmp$
  Dim i&, iR&, r&, j&, c&, k&, q&, sRow&, sCol&, sR&, sC&, Nhom$, strNhom$, Nhom2$
 
  sArr = Range("A3:P26").Value
  sR = Application.Count(Range("B3:B26"))
  sRow = UBound(sArr): sCol = UBound(sArr, 2)
 
TroLai:
  ReDim Res(1 To sRow, 1 To sCol)
  ReDim a(1 To sR, 1 To 4) 'Mang thu tu dong co du lieu va thu tu cot ket qua
  k = 0
  For i = 1 To UBound(sArr)
    Res(i, 1) = sArr(i, 1)
    If sArr(i, 2) > 0 Then
      If sArr(i, 2) >= sR Then MsgBox ("Vo nghiem"): Exit Sub
      k = k + 1
      a(k, 1) = i 'Thu tu dong sArr
      a(k, 2) = sArr(i, 2) 'So cot ket qua
      a(k, 4) = "|"
      Res(i, 2) = sArr(i, 2)
    End If
  Next i
 
  For i = 1 To sR 'thu tu DongNguon mang "a"
    c = 0
    sC = a(i, 2) 'So cot Nguon
    r = a(i, 1) 'thu tu DongNguon sArr
    Nhom = sArr(r, 1) & "|"
    uni = UniqueRand(sR) 'Mang thu tu ngau nhien khong trung
    
    For j = 1 To sR
      iR = uni(j, 1) 'thu tu DongKetQua mang "a"
      If iR > 0 And iR <> i Then
        If a(iR, 2) > a(iR, 3) Then
          uni(j, 1) = Empty 'Loai bo dong uni(j, 1)
          c = c + 1 'thu tu cot nguon
          a(iR, 3) = a(iR, 3) + 1 'Thu tu Cot ket qua dong iR
          tmp = sArr(r, c + 2) 'Ket qua
          Res(a(iR, 1), a(iR, 3) + 2) = tmp
          a(iR, 4) = a(iR, 4) & Nhom
          If c = sC Then Exit For
        End If
      End If
    Next j

    Do While c < sC 'Dieu chinh ket qua cac dong
      For j = 1 To sR
        If a(j, 2) > a(j, 3) Then 'dong ket qua con thieu
          strNhom = a(j, 4)
          Nhom2 = sArr(a(j, 1), 1)
          For j2 = 1 To sR ' dong thay the
            If InStr(1, a(j2, 4), "|" & Nhom) = 0 Then
              S = Split(a(j2, 4), "|")
              For q = 1 To UBound(S) - 1 ' thu tu cot cua dong thay the
                If InStr(1, strNhom, "|" & S(q) & "|") = 0 And Nhom2 <> S(q) Then
                  c = c + 1
                  tmp = sArr(r, c + 2) 'Ket qua moi
                  a(j, 3) = a(j, 3) + 1 'Thu tu Cot ket qua dong j
                  Res(a(j, 1), a(j, 3) + 2) = Res(a(j2, 1), q + 2) 'chinh ket qua theo dong moi
                  Res(a(j2, 1), q + 2) = tmp 'Thay ket qua moi
                  a(j2, 4) = Replace(a(j2, 4), "|" & S(q) & "|", "|" & Nhom) 'Chinh strNhom thay the
                  a(j, 4) = a(j, 4) & S(q) & "|" ' strNhom moi
                  Exit For
                End If
              Next q
              If q < UBound(S) Then Exit For
            End If
          Next j2
          If j2 < sR + 1 Then Exit For Else GoTo TroLai 'Botay.com, chay lai tu dau
        End If
      Next j
    Loop
  Next i
  Range("R3").Resize(sRow, sCol) = Res
End Sub

Function UniqueRand(ByVal N As Long) As Variant
  Dim Arr() As Long, i&, RndNum&, tmp&
  ReDim Arr(1 To N, 1 To 1)
  Randomize
  For i = 1 To N
    RndNum = Int(N * Rnd() + 1)
    If Arr(RndNum, 1) = 0 Then tmp = RndNum Else tmp = Arr(RndNum, 1)
    If Arr(N, 1) = 0 Then Arr(RndNum, 1) = N Else Arr(RndNum, 1) = Arr(N, 1)
    Arr(N, 1) = tmp
    N = N - 1
  Next i
  UniqueRand = Arr
End Function
 
Upvote 0
Kiểm tra lại kết quả
Mã:
Sub XYZ()
  Dim sArr(), a(), uni, S, Res(), tmp$
  Dim i&, iR&, r&, j&, c&, k&, q&, sRow&, sCol&, sR&, sC&, Nhom$, strNhom$, Nhom2$

  sArr = Range("A3:P26").Value
  sR = Application.Count(Range("B3:B26"))
  sRow = UBound(sArr): sCol = UBound(sArr, 2)

TroLai:
  ReDim Res(1 To sRow, 1 To sCol)
  ReDim a(1 To sR, 1 To 4) 'Mang thu tu dong co du lieu va thu tu cot ket qua
  k = 0
  For i = 1 To UBound(sArr)
    Res(i, 1) = sArr(i, 1)
    If sArr(i, 2) > 0 Then
      If sArr(i, 2) >= sR Then MsgBox ("Vo nghiem"): Exit Sub
      k = k + 1
      a(k, 1) = i 'Thu tu dong sArr
      a(k, 2) = sArr(i, 2) 'So cot ket qua
      a(k, 4) = "|"
      Res(i, 2) = sArr(i, 2)
    End If
  Next i

  For i = 1 To sR 'thu tu DongNguon mang "a"
    c = 0
    sC = a(i, 2) 'So cot Nguon
    r = a(i, 1) 'thu tu DongNguon sArr
    Nhom = sArr(r, 1) & "|"
    uni = UniqueRand(sR) 'Mang thu tu ngau nhien khong trung
   
    For j = 1 To sR
      iR = uni(j, 1) 'thu tu DongKetQua mang "a"
      If iR > 0 And iR <> i Then
        If a(iR, 2) > a(iR, 3) Then
          uni(j, 1) = Empty 'Loai bo dong uni(j, 1)
          c = c + 1 'thu tu cot nguon
          a(iR, 3) = a(iR, 3) + 1 'Thu tu Cot ket qua dong iR
          tmp = sArr(r, c + 2) 'Ket qua
          Res(a(iR, 1), a(iR, 3) + 2) = tmp
          a(iR, 4) = a(iR, 4) & Nhom
          If c = sC Then Exit For
        End If
      End If
    Next j

    Do While c < sC 'Dieu chinh ket qua cac dong
      For j = 1 To sR
        If a(j, 2) > a(j, 3) Then 'dong ket qua con thieu
          strNhom = a(j, 4)
          Nhom2 = sArr(a(j, 1), 1)
          For j2 = 1 To sR ' dong thay the
            If InStr(1, a(j2, 4), "|" & Nhom) = 0 Then
              S = Split(a(j2, 4), "|")
              For q = 1 To UBound(S) - 1 ' thu tu cot cua dong thay the
                If InStr(1, strNhom, "|" & S(q) & "|") = 0 And Nhom2 <> S(q) Then
                  c = c + 1
                  tmp = sArr(r, c + 2) 'Ket qua moi
                  a(j, 3) = a(j, 3) + 1 'Thu tu Cot ket qua dong j
                  Res(a(j, 1), a(j, 3) + 2) = Res(a(j2, 1), q + 2) 'chinh ket qua theo dong moi
                  Res(a(j2, 1), q + 2) = tmp 'Thay ket qua moi
                  a(j2, 4) = Replace(a(j2, 4), "|" & S(q) & "|", "|" & Nhom) 'Chinh strNhom thay the
                  a(j, 4) = a(j, 4) & S(q) & "|" ' strNhom moi
                  Exit For
                End If
              Next q
              If q < UBound(S) Then Exit For
            End If
          Next j2
          If j2 < sR + 1 Then Exit For Else GoTo TroLai 'Botay.com, chay lai tu dau
        End If
      Next j
    Loop
  Next i
  Range("R3").Resize(sRow, sCol) = Res
End Sub

Function UniqueRand(ByVal N As Long) As Variant
  Dim Arr() As Long, i&, RndNum&, tmp&
  ReDim Arr(1 To N, 1 To 1)
  Randomize
  For i = 1 To N
    RndNum = Int(N * Rnd() + 1)
    If Arr(RndNum, 1) = 0 Then tmp = RndNum Else tmp = Arr(RndNum, 1)
    If Arr(N, 1) = 0 Then Arr(RndNum, 1) = N Else Arr(RndNum, 1) = Arr(N, 1)
    Arr(N, 1) = tmp
    N = N - 1
  Next i
  UniqueRand = Arr
End Function
Cảm ơn Hieu CD nhiều. Bạn đã viết lại và không dùng dic nên mình đọc dễ hiểu hơn. Cảm ơn bạn. Mình sẽ chạy thử.
 
Upvote 0
Web KT
Back
Top Bottom