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

titanic20072007

Thành viên hoạt động
Tham gia ngày
10 Tháng bảy 2007
Bài viết
186
Được thích
7
Điểm
670
Nơi ở
Hà Nam
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

excel_lv1.5

Thành viên tiêu biểu
Tham gia ngày
20 Tháng mười 2017
Bài viết
529
Được thích
873
Điểm
360
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
 

titanic20072007

Thành viên hoạt động
Tham gia ngày
10 Tháng bảy 2007
Bài viết
186
Được thích
7
Điểm
670
Nơi ở
Hà Nam
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

excel_lv1.5

Thành viên tiêu biểu
Tham gia ngày
20 Tháng mười 2017
Bài viết
529
Được thích
873
Điểm
360
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
 

HieuCD

Thành viên gạo cội
Tham gia ngày
14 Tháng chín 2010
Bài viết
6,101
Được thích
11,242
Điểm
1,560
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
 

titanic20072007

Thành viên hoạt động
Tham gia ngày
10 Tháng bảy 2007
Bài viết
186
Được thích
7
Điểm
670
Nơi ở
Hà Nam
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

excel_lv1.5

Thành viên tiêu biểu
Tham gia ngày
20 Tháng mười 2017
Bài viết
529
Được thích
873
Điểm
360
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:

HieuCD

Thành viên gạo cội
Tham gia ngày
14 Tháng chín 2010
Bài viết
6,101
Được thích
11,242
Điểm
1,560
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
 

titanic20072007

Thành viên hoạt động
Tham gia ngày
10 Tháng bảy 2007
Bài viết
186
Được thích
7
Điểm
670
Nơi ở
Hà Nam
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?
 
Top Bottom