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

Liên hệ QC
T

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
Sắp xếp theo thời gian sắp xếp theo bầu chọn
titanic20072007 đã viết:
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.
Nhấp chuột vào đây để mở rộng...
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
excel_lv1.5 đã viết:
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
Nhấp chuột vào đây để mở rộng...
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
titanic20072007 đã viết:
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é.
Nhấp chuột vào đây để mở rộng...
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
titanic20072007 đã viết:
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.
Nhấp chuột vào đây để mở rộng...
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
excel_lv1.5 đã viết:
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
Nhấp chuột vào đây để mở rộng...
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:

HieuCD đã viết:
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
Nhấp chuột vào đây để mở rộng...
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
titanic20072007 đã viết:
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?
Nhấp chuột vào đây để mở rộ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
titanic20072007 đã viết:
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?
Nhấp chuột vào đây để mở rộ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
excel_lv1.5 đã viết:
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
Nhấp chuột vào đây để mở rộng...
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
HieuCD đã viết:
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
Nhấp chuột vào đây để mở rộng...
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
titanic20072007 đã viết:
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?
Nhấp chuột vào đây để mở rộ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
HieuCD đã viết:
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
Nhấp chuột vào đây để mở rộng...
Cảm ơn bạn nhiều. Code chạy đã chuẩn rồi.
 
Upvote 0
excel_lv1.5 đã viết:
Ah, tôi đã sửa rồi, bạn copy code lại rồi chạy lại.
Nhấp chuột vào đây để mở rộng...
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
HieuCD đã viết:
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
Nhấp chuột vào đây để mở rộng...
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
titanic20072007 đã viết:
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.
Nhấp chuột vào đây để mở rộng...
"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
HieuCD đã viết:
"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
Nhấp chuột vào đây để mở rộng...
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
titanic20072007 đã viết:
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.
Nhấp chuột vào đây để mở rộng...
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
HieuCD đã viết:
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
Nhấp chuột vào đây để mở rộng...
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
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

H
Tính và sắp xếp theo thư tự tăng dần có điều kiệu (có dữ liệu trùng nhau)
Trả lời
0
Đọc
4
hoangnam_vt
H
ongke0711
  • Question
Tải hóa đơn điện tử (https://hoadondientu.gdt.gov.vn/) Excel Vba
    • Thích
    • Yêu thích
11 12 13
Trả lời
248
Đọc
13K
hoidebiet1710
hoidebiet1710
B
Định dạng condition formatting, đếm hỗn hợp dữ liệu merge và không merge
Trả lời
12
Đọc
153
ptm0412
ptm0412
Nguyễn Duy Tuân
  • Question
Chia sẻ ControlForOffice - Bộ công cụ điều khiển Office/Excel
    • Thích
6 7 8
Trả lời
149
Đọc
95K
Nguyễn Duy Tuân
Nguyễn Duy Tuân
20050911
File Excel lỗi ''The file could not be accessed. Try one of the following:.."
Trả lời
0
Đọc
26
20050911
20050911
B
Lọc dữ liệu trùng, đếm số lần, tự tô màu theo điều kiện.
Trả lời
5
Đọc
131
batista911
B
N
Vẽ biểu đồ kết hợp nhiều yếu tố trong excel
Trả lời
2
Đọc
90
Ny Ny 2024
N
Tuấn Bụng Bự
  • Question
Tìm Bộ 8 số xuất hiện nhiều nhất trong random( 1 - 80)
2
Trả lời
28
Đọc
648
Tuấn Bụng Bự
Tuấn Bụng Bự
C
Chia sẻ: Kết quả xổ số Keno
    • Cười
    • Thích
Trả lời
9
Đọc
265
ptm0412
ptm0412
P
Tổng hợp dữ liệu từ các sheet theo chọn lọc
Trả lời
14
Đọc
288
ptm0412
ptm0412
T
Tối ưu hóa hàm lấy dữ liệu từ bảng Tổng sang bảng chi tiết
Trả lời
7
Đọc
227
Hoàng Tuấn 868
H
nguyenphuochien166
Cách Vlookup hoặc cách lấy thông tin dữ liệu có dấu mũ lũy thừa?
    • Cười
Trả lời
6
Đọc
113
tigertiger
tigertiger
T
Không đếm dữ liệu rỗng trong PivotTable
Trả lời
8
Đọc
1K
hoangtuaotrang_hp_vn
H
C
Công thức tự nhập liệu số lượng nhập khi bị âm
Trả lời
1
Đọc
98
hoangtuaotrang_hp_vn
H
kimtanmap
  • Question
Nhờ viết code VBA Macro lập lại.
Trả lời
5
Đọc
166
kimtanmap
kimtanmap
dung09031989
Xin giúp công thức tô màu các ô phía sau khi kế hoạch đặt hàng thiếu so với tồn kho.?
Trả lời
1
Đọc
84
hoangtuaotrang_hp_vn
H
huynhnhu1234
Tìm giá vé máy bay một chiều và khứ hồi
Trả lời
0
Đọc
60
huynhnhu1234
huynhnhu1234
V
[Nhờ giúp đỡ] Cách tìm thời gian bị trùng trong excel ở nhiều thời gian khác nhau
Trả lời
7
Đọc
136
tranvansau278
T
N
Hàm tìm giá trị theo giờ vào - ra
Trả lời
6
Đọc
127
Nguyễn Linh hn94
N
zarra
Cần giúp tạo form in mã vạch cho vật tư theo SL cụ thể.
Trả lời
4
Đọc
169
zarra
zarra
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

Back
Top Bottom