Random sắp xếp Theo cột (9 người xem)

[Hahai_123]

Anh chị giúp em làm cái Random tự động xếp các số ngẫu nhiên vào các cột.
Ví dụ: S1 (ca Sáng 1) sẽ có 4 nhánh (N1, N2, N3, N5), Nếu S1 đã có số đó rồi thì sang ca C1 hoặc C2 hoặc T1 sẽ xếp cho sang nhánh khác và ngược lại.

 

[SA_DQ]

Bạn nói suông vậy thì chả ai hiểu bạn muốn gì, hãy thì dụ cụ thể đi bạn.

& bài này chắc phải xài VBA mới đặng.

 

[Hahai_123]

Anh chị giúp em làm cái Random tự động xếp các số ngẫu nhiên vào các cột.
Ví dụ: S1 (ca Sáng 1) sẽ có 4 nhánh (N1, N2, N3, N5), Nếu S1 đã có số đó rồi thì sang ca C1 hoặc C2 hoặc T1 sẽ xếp cho sang nhánh khác và ngược lại.

Em gửi lại mẫu Random

 

[Ba Tê]

Em gửi lại mẫu Random

Chuyện này giải quyết bằng VBA chắc cũng "chua lét", dùng hàm Excel khó mà giải quyết

 

[dazkangel]

Chuyện này giải quyết bằng VBA chắc cũng "chua lét", dùng hàm Excel khó mà giải quyết

Viết hàm chắc vẫn được, chỉ có điều nó sẽ nhảy random liên tục không có vụ có định số.

 

[SA_DQ]

Macro này chỉ mới xếp dữ liệu vô các vùng ô thôi; Chưa tính đến điều kiện trùng cột giữa các vùng:

Sub SapXepNgauNhienKhongTrungCot()
Dim lRs As Long, J As Long, W As Integer, Cot As Integer, Dem As Integer, Num As Double
Const MyColor As Integer = 34

1 'Xêp Các Côt Sô Liêu Ngâu Nhiên    '
Randomize
For W = 1 To 4
    lRs = Cells(65500, W).End(xlUp).Row
    Cot = Choose(W, 5, 9, 13, 17, 35)
    Cells(3, Cot).Resize(lRs, 4).Clear
    For J = 3 To lRs
        Dem = 3 * Rnd() \ 1
        Num = Cells(J, W).Value
        Cells(65500, Cot + Dem).End(xlUp).Offset(1).Value = Num
        Cells(65500, Cot + Dem).End(xlUp).Offset(1).Interior.ColorIndex = MyColor + W
    Next J
Next W
End Sub

& kết quả mà macro đem tới:

S1

C1

C2

T1

N1

N2

N3

N5

N1

N2

N3

N5

N1

N2

N3

N5

N1

N2

N3

N5

301​

305​

348​

311​

304​

317​

345​

301​

407​

319​

312​

318​

365​

303​

319​

372​

357​

317​

351​

338​

305​

335​

347​

311​

383​

324​

332​

368​

415​

318​

328​

379​

409​

335​

390​

402​

375​

343​

348​

338​

347​

328​

340​

379​

410​

367​

332​

380​

461​

343​

394​

416​

402​

346​

357​

351​

429​

391​

365​

422​

391​

340​

425​

479​

345​

459​

469​

461​

369​

388​

360​

428​

392​

440​

393​

426​

312​

485​

346​

442​

477​

477​

374​

390​

417​

476​

393​

390​

414​

428​

415​

375​

445​

334​

394​

409​

429​

430​

398​

469​

478​

489​

468​

388​

301​

395​

416​

317​

339​

426​

339​

424​

417​

448​

421​

495​

432​

358​

495​

350​

469​

459​

346​

385​

499​

496​

369​

480​

479​

496​

410​

473​

382​

341​

485​

311​

498​

333​

490​

334​

492​

335​

329​

338​

305​

351​

429​

395​

432​

459​

442​

445​

 

[VetMini]

Chuyện này giải quyết bằng VBA chắc cũng "chua lét", dùng hàm Excel khó mà giải quyết

Chua té đế luôn. Răng đầm thì quá dễ. Nhưng cái màn giải quyết "trùng nhánh" có thể chạy vòng vô tận. Có tới 4 ca để xét trùng, có mà hộc máu.

 

[SA_DQ]

Vì chủ bài đăng cần ngẫu nhiên xếp vô 4 cột của 4 nhánh, nên ta có thể:
Nhánh 1:
Cột 1 chứa các số chẵn mà chia hết cho 2; Cột 2 là số chẵn chia hết cho 3,. . . . .
Các nhánh sau đổi lại
???

 

[VetMini]

Vì chủ bài đăng cần ngẫu nhiên xếp vô 4 cột của 4 nhánh, nên ta có thể:
Nhánh 1:
Cột 1 chứa các số chẵn mà chia hết cho 2; Cột 2 là số chẵn chia hết cho 3,. . . . .
Các nhánh sau đổi lại
???

Thứ nhất, như vậy đâu còn là ngẫu nhiên.
Thứ hai, hai cột đầu đã chiếm gần hết các số. Và theo xác suất số chẵn lẻ, cột đầu chiếm gần hết các số chẵn và cột 2 chiếm gần hết các số lẻ.

Nếu phải sắp xếp như thế thì cứ chia ra hai chẵn lẻ. Hai cột cuối bốc trước. Chỗ còn lại chia cho hai cột đầu theo đúng chẵn lẻ.

 

[Ba Tê]

Macro này chỉ mới xếp dữ liệu vô các vùng ô thôi; Chưa tính đến điều kiện trùng cột giữa các vùng:

Sub SapXepNgauNhienKhongTrungCot()
Dim lRs As Long, J As Long, W As Integer, Cot As Integer, Dem As Integer, Num As Double
Const MyColor As Integer = 34

1 'Xêp Các Côt Sô Liêu Ngâu Nhiên    '
Randomize
For W = 1 To 4
    lRs = Cells(65500, W).End(xlUp).Row
    Cot = Choose(W, 5, 9, 13, 17, 35)
    Cells(3, Cot).Resize(lRs, 4).Clear
    For J = 3 To lRs
        Dem = 3 * Rnd() \ 1
        Num = Cells(J, W).Value
        Cells(65500, Cot + Dem).End(xlUp).Offset(1).Value = Num
        Cells(65500, Cot + Dem).End(xlUp).Offset(1).Interior.ColorIndex = MyColor + W
    Next J
Next W
End Sub

& kết quả mà macro đem tới:

S1

C1

C2

T1

N1

N2

N3

N5

N1

N2

N3

N5

N1

N2

N3

N5

N1

N2

N3

N5

301​

305​

348​

311​

304​

317​

345​

301​

407​

319​

312​

318​

365​

303​

319​

372​

357​

317​

351​

338​

305​

335​

347​

311​

383​

324​

332​

368​

415​

318​

328​

379​

409​

335​

390​

402​

375​

343​

348​

338​

347​

328​

340​

379​

410​

367​

332​

380​

461​

343​

394​

416​

402​

346​

357​

351​

429​

391​

365​

422​

391​

340​

425​

479​

345​

459​

469​

461​

369​

388​

360​

428​

392​

440​

393​

426​

312​

485​

346​

442​

477​

477​

374​

390​

417​

476​

393​

390​

414​

428​

415​

375​

445​

334​

394​

409​

429​

430​

398​

469​

478​

489​

468​

388​

301​

395​

416​

317​

339​

426​

339​

424​

417​

448​

421​

495​

432​

358​

495​

350​

469​

459​

346​

385​

499​

496​

369​

480​

479​

496​

410​

473​

382​

341​

485​

311​

498​

333​

490​

334​

492​

335​

329​

338​

305​

351​

429​

395​

432​

459​

442​

445​

Yêu cầu là N1 và N2 số dòng bằng nhau hoặc N2=N1+1.

Bài đã được tự động gộp: 18/7/20

Chua té đế luôn. Răng đầm thì quá dễ. Nhưng cái màn giải quyết "trùng nhánh" có thể chạy vòng vô tận. Có tới 4 ca để xét trùng, có mà hộc máu.

Cái này gần giống như xếp Thời khóa biểu cho Giáo viên.
Không trùng ngày, không trùng lớp, không trùng tiết dạy.

 

[befaint]

Cái này chắc bốc giấy xếp lịch coi thi?

Vậy cứ ai đã xếp N nào rồi thì ca kế tiếp không bốc ở N tương ứng nữa là được.

 

[VetMini]

Cái này chắc bốc giấy xếp lịch coi thi?

Vậy cứ ai đã xếp N nào rồi thì ca kế tiếp không bốc ở N tương ứng nữa là được.

Nếu chỉ có 2 ca thì dễ. Xếp xong một ca. Chỉ việc đọc ngược lại thì thành ca thứ hai.
Nhưng ở đây có đến 4 ca. Vì vậy tôi mới nói có khả năng lòng vòng đến sáng mai.

 

[Hahai_123]

Macro này chỉ mới xếp dữ liệu vô các vùng ô thôi; Chưa tính đến điều kiện trùng cột giữa các vùng:

Sub SapXepNgauNhienKhongTrungCot()
Dim lRs As Long, J As Long, W As Integer, Cot As Integer, Dem As Integer, Num As Double
Const MyColor As Integer = 34

1 'Xêp Các Côt Sô Liêu Ngâu Nhiên    '
Randomize
For W = 1 To 4
    lRs = Cells(65500, W).End(xlUp).Row
    Cot = Choose(W, 5, 9, 13, 17, 35)
    Cells(3, Cot).Resize(lRs, 4).Clear
    For J = 3 To lRs
        Dem = 3 * Rnd() \ 1
        Num = Cells(J, W).Value
        Cells(65500, Cot + Dem).End(xlUp).Offset(1).Value = Num
        Cells(65500, Cot + Dem).End(xlUp).Offset(1).Interior.ColorIndex = MyColor + W
    Next J
Next W
End Sub

& kết quả mà macro đem tới:

S1

C1

C2

T1

N1

N2

N3

N5

N1

N2

N3

N5

N1

N2

N3

N5

N1

N2

N3

N5

301​

305​

348​

311​

304​

317​

345​

301​

407​

319​

312​

318​

365​

303​

319​

372​

357​

317​

351​

338​

305​

335​

347​

311​

383​

324​

332​

368​

415​

318​

328​

379​

409​

335​

390​

402​

375​

343​

348​

338​

347​

328​

340​

379​

410​

367​

332​

380​

461​

343​

394​

416​

402​

346​

357​

351​

429​

391​

365​

422​

391​

340​

425​

479​

345​

459​

469​

461​

369​

388​

360​

428​

392​

440​

393​

426​

312​

485​

346​

442​

477​

477​

374​

390​

417​

476​

393​

390​

414​

428​

415​

375​

445​

334​

394​

409​

429​

430​

398​

469​

478​

489​

468​

388​

301​

395​

416​

317​

339​

426​

339​

424​

417​

448​

421​

495​

432​

358​

495​

350​

469​

459​

346​

385​

499​

496​

369​

480​

479​

496​

410​

473​

382​

341​

485​

311​

498​

333​

490​

334​

492​

335​

329​

338​

305​

351​

429​

395​

432​

459​

442​

445​

Cái này được đó ạ, Bác thêm giúp em điều kiện là N5 tối đa là 2 số, Nhánh 3 tối đa là 5 số còn lại N1 và N2 bằng nhau hoặc N1<N2 1 số

 

[SA_DQ]

Mình sửa lại macro theo ý của bạn như sau:

Sub SapXepNgauNhienKhongTrungCot()
 Dim lRs As Long, J As Long, W As Integer, Cot As Integer, Num As Double, Tmp As Integer
 Const MyColor As Integer = 34
 Dim GPE As String
 '  Xêp Các Côt Sô Liêu Ngâu Nhiên    '
 Randomize
 For W = 1 To 4 ' Cot So Lieu   '
    lRs = Cells(65500, W).End(xlUp).Row
    Cot = Choose(W, 5, 9, 13, 17, 35)
    Cells(3, Cot).Resize(lRs, 4).Clear
    GPE = ""
    For J = 3 To lRs
        Num = 1 + lRs * 9 \ 1
        If Num Mod 2 = 0 Then
            GPE = GPE & Right("00" & CStr(J), 3)
        Else
            GPE = Right("00" & CStr(J), 3) & GPE
        End If
    Next J
    For J = 1 To Len(GPE) Step 3
        Tmp = Cells(CInt(Mid(GPE, J, 3)), W).Value
        If J < 5 Then
            Cells(65500, Cot + 3).End(xlUp).Offset(1).Value = Tmp
        ElseIf J < 22 Then
            Cells(65500, Cot + 2).End(xlUp).Offset(1).Value = Tmp
        Else
            Cells(65500, Cot + (J Mod 2)).End(xlUp).Offset(1).Value = Tmp
        End If
    Next J
 Next W
End Sub

S1

C1

C2

T1

N1

N2

N3

N5

N1

N2

N3

N5

N1

N2

N3

N5

N1

N2

N3

N5

369​

350​

468​

301​

343​

345​

305​

301​

390​

351​

496​

335​

367​

372​

319​

303​

334​

485​

445​

490​

346​

347​

311​

304​

347​

346​

469​

311​

379​

380​

328​

318​

479​

477​

442​

348​

351​

317​

329​

495​

459​

391​

393​

332​

469​

461​

415​

357​

360​

335​

498​

410​

429​

414​

415​

340​

459​

417​

382​

369​

374​

338​

385​

383​

395​

426​

428​

365​

416​

409​

375​

388​

339​

440​

478​

489​

402​

394​

390​

394​

430​

476​

339​

358​

390​

388​

395​

402​

432​

428​

424​

425​

375​

357​

409​

416​

426​

422​

410​

495​

351​

348​

417​

421​

407​

398​

496​

499​

346​

345​

429​

448​

393​

392​

473​

312​

343​

338​

459​

461​

391​

379​

333​

338​

335​

317​

469​

477​

368​

365​

429​

432​

311​

305​

479​

480​

340​

332​

442​

445​

301​

485​

341​

328​

324​

492​

334​

319​

318​

305​

317​

312​

 

[Ba Tê]

Mình sửa lại macro theo ý của bạn như sau:

Sub SapXepNgauNhienKhongTrungCot()
Dim lRs As Long, J As Long, W As Integer, Cot As Integer, Num As Double, Tmp As Integer
Const MyColor As Integer = 34
Dim GPE As String
'  Xêp Các Côt Sô Liêu Ngâu Nhiên    '
Randomize
For W = 1 To 4 ' Cot So Lieu   '
    lRs = Cells(65500, W).End(xlUp).Row
    Cot = Choose(W, 5, 9, 13, 17, 35)
    Cells(3, Cot).Resize(lRs, 4).Clear
    GPE = ""
    For J = 3 To lRs
        Num = 1 + lRs * 9 \ 1
        If Num Mod 2 = 0 Then
            GPE = GPE & Right("00" & CStr(J), 3)
        Else
            GPE = Right("00" & CStr(J), 3) & GPE
        End If
    Next J
    For J = 1 To Len(GPE) Step 3
        Tmp = Cells(CInt(Mid(GPE, J, 3)), W).Value
        If J < 5 Then
            Cells(65500, Cot + 3).End(xlUp).Offset(1).Value = Tmp
        ElseIf J < 22 Then
            Cells(65500, Cot + 2).End(xlUp).Offset(1).Value = Tmp
        Else
            Cells(65500, Cot + (J Mod 2)).End(xlUp).Offset(1).Value = Tmp
        End If
    Next J
Next W
End Sub

S1

C1

C2

T1

N1

N2

N3

N5

N1

N2

N3

N5

N1

N2

N3

N5

N1

N2

N3

N5

369​

350​

468​

301​

343​

345​

305​

301​

390​

351​

496​

335​

367​

372​

319​

303​

334​

485​

445​

490​

346​

347​

311​

304​

347​

346​

469​

311​

379​

380​

328​

318​

479​

477​

442​

348​

351​

317​

329​

495​

459​

391​

393​

332​

469​

461​

415​

357​

360​

335​

498​

410​

429​

414​

415​

340​

459​

417​

382​

369​

374​

338​

385​

383​

395​

426​

428​

365​

416​

409​

375​

388​

339​

440​

478​

489​

402​

394​

390​

394​

430​

476​

339​

358​

390​

388​

395​

402​

432​

428​

424​

425​

375​

357​

409​

416​

426​

422​

410​

495​

351​

348​

417​

421​

407​

398​

496​

499​

346​

345​

429​

448​

393​

392​

473​

312​

343​

338​

459​

461​

391​

379​

333​

338​

335​

317​

469​

477​

368​

365​

429​

432​

311​

305​

479​

480​

340​

332​

442​

445​

301​

485​

341​

328​

324​

492​

334​

319​

318​

305​

317​

312​

Chỉ xem hình, Dòng 3:
301, N5, S1. Trùng với N5, C1.
-------------------------------------------------------------------
Tôi nghĩ: Không có điều kiện "ngẫu nhiên" thì còn có thể.
Randomize, có lúc nó chạy lòng vòng như bài #12 đã nói.

 

[Hahai_123]

Mình sửa lại macro theo ý của bạn như sau:

Sub SapXepNgauNhienKhongTrungCot()
Dim lRs As Long, J As Long, W As Integer, Cot As Integer, Num As Double, Tmp As Integer
Const MyColor As Integer = 34
Dim GPE As String
'  Xêp Các Côt Sô Liêu Ngâu Nhiên    '
Randomize
For W = 1 To 4 ' Cot So Lieu   '
    lRs = Cells(65500, W).End(xlUp).Row
    Cot = Choose(W, 5, 9, 13, 17, 35)
    Cells(3, Cot).Resize(lRs, 4).Clear
    GPE = ""
    For J = 3 To lRs
        Num = 1 + lRs * 9 \ 1
        If Num Mod 2 = 0 Then
            GPE = GPE & Right("00" & CStr(J), 3)
        Else
            GPE = Right("00" & CStr(J), 3) & GPE
        End If
    Next J
    For J = 1 To Len(GPE) Step 3
        Tmp = Cells(CInt(Mid(GPE, J, 3)), W).Value
        If J < 5 Then
            Cells(65500, Cot + 3).End(xlUp).Offset(1).Value = Tmp
        ElseIf J < 22 Then
            Cells(65500, Cot + 2).End(xlUp).Offset(1).Value = Tmp
        Else
            Cells(65500, Cot + (J Mod 2)).End(xlUp).Offset(1).Value = Tmp
        End If
    Next J
Next W
End Sub

S1

C1

C2

T1

N1

N2

N3

N5

N1

N2

N3

N5

N1

N2

N3

N5

N1

N2

N3

N5

369​

350​

468​

301​

343​

345​

305​

301​

390​

351​

496​

335​

367​

372​

319​

303​

334​

485​

445​

490​

346​

347​

311​

304​

347​

346​

469​

311​

379​

380​

328​

318​

479​

477​

442​

348​

351​

317​

329​

495​

459​

391​

393​

332​

469​

461​

415​

357​

360​

335​

498​

410​

429​

414​

415​

340​

459​

417​

382​

369​

374​

338​

385​

383​

395​

426​

428​

365​

416​

409​

375​

388​

339​

440​

478​

489​

402​

394​

390​

394​

430​

476​

339​

358​

390​

388​

395​

402​

432​

428​

424​

425​

375​

357​

409​

416​

426​

422​

410​

495​

351​

348​

417​

421​

407​

398​

496​

499​

346​

345​

429​

448​

393​

392​

473​

312​

343​

338​

459​

461​

391​

379​

333​

338​

335​

317​

469​

477​

368​

365​

429​

432​

311​

305​

479​

480​

340​

332​

442​

445​

301​

485​

341​

328​

324​

492​

334​

319​

318​

305​

317​

312​

Nhưng cái này là xếp lại thôi chứ không phải Random. Anh có cách nào mỗi lần bấm chạy thì nó sẽ tự động thay đổi không ạ? Không cần lọc số trùng nhau trong cả 4 ca nữa, mà Ví dụ; S1 301 N1 thì sang C2 301 N1 cũng được, hoặc N khác thì tốt.

 

[SA_DQ]

Bạn thay dòng lệnh mới này xem có khả dĩ gì hơn không:
Num = 9 + (Rnd * 99 * J) \ 1

 

[HieuCD]

Em gửi lại mẫu Random

Với dữ liệu "dể thở" trong file, chỉ cần dùng cách "hồi tố" 1 cột dữ liệu đang xét

Sub XYZ()
  Dim Arr(), sArr(), dicArr(), tRes(), Res(), sR As Variant
  Dim eRow&, sRow&, i&, j&, c&, c2&, k&, ik&, iKey, tmp, Q&
  Const sColData& = 4 ' Cot So Lieu
  Const sColRes& = 4 'So Cot Ket qua cua 1 cot du lieu
 
  ReDim sArr(1 To sColData): ReDim dicArr(1 To sColRes):  ReDim Res(1 To sColData)
  eRow = Range("A3").CurrentRegion.Row + Range("A3").CurrentRegion.Rows.Count - 1
  ReDim Arr(1 To eRow - 2, 1 To sColRes)
  For j = 1 To sColData
    sArr(j) = Range(Cells(3, j), Cells(Rows.Count, j).End(xlUp)).Value
    Res(j) = Arr
  Next j
  For c = 1 To sColRes
    Set dicArr(c) = CreateObject("scripting.dictionary")
  Next c
 
  Randomize
  For j = 1 To sColData
    Arr = sArr(j):    sRow = UBound(Arr)
    i = (sRow - 7) \ 2
    sR = Array(0, i, sRow - 7 - i, 5, 2)
    For c = 1 To sColRes
      k = 0
      Do
        ik = Int(Rnd * sRow + 1)
        iKey = Arr(ik, 1)
        If dicArr(c).exists(iKey) = False Then
          k = k + 1
          Res(j)(k, c) = iKey
          dicArr(c).Add iKey, ""
          Arr(ik, 1) = Arr(sRow, 1)
          sRow = sRow - 1
        Else
            For c2 = 1 To c - 1
              If dicArr(c2).exists(iKey) = False Then
                tRes = Res(j)
                For i = 1 To UBound(tRes)
                  tmp = tRes(i, c2)
                  If tmp = Empty Then Exit For
                  If dicArr(c).exists(tmp) = False Then
                    k = k + 1
                    Res(j)(k, c) = tmp
                    dicArr(c).Add tmp, ""
                    Arr(ik, 1) = Arr(sRow, 1)
                    sRow = sRow - 1
                    
                    Res(j)(i, c2) = iKey
                    dicArr(c2).Add iKey, ""
                    dicArr(c2).Remove (tmp)
                    Exit For
                  End If
                Next i
                If tmp <> Empty Then Q = 0: Exit For
              End If
            Next c2
        End If
        Q = Q + 1
        If Q = 1000 Then
          MsgBox ("Tieu Roi, Phai viet code moi chi tiet hon !!!"): Exit Sub
        End If
      Loop Until k = sR(c)
    Next c
  Next j
  Application.ScreenUpdating = False
  Range("E3:T" & eRow).ClearContents
  For j = 1 To sColData
    Cells(3, sColRes * j + 1).Resize(UBound(Res(j)), sColRes) = Res(j)
  Next j
  Application.ScreenUpdating = True
End Sub

 

[Ba Tê]

Không cần lọc số trùng nhau trong cả 4 ca nữa, mà Ví dụ; S1 301 N1 thì sang C2 301 N1 cũng được, hoặc N khác thì tốt.

Xếp ngẫu nhiên, "Thua" thì làm lại.
Cứ bấm nút chừng nào thấy khoái thì dùng kết quả đó.

 

[Hahai_123]

Với dữ liệu "dể thở" trong file, chỉ cần dùng cách "hồi tố" 1 cột dữ liệu đang xét

Sub XYZ()
  Dim Arr(), sArr(), dicArr(), tRes(), Res(), sR As Variant
  Dim eRow&, sRow&, i&, j&, c&, c2&, k&, ik&, iKey, tmp, Q&
  Const sColData& = 4 ' Cot So Lieu
  Const sColRes& = 4 'So Cot Ket qua cua 1 cot du lieu

  ReDim sArr(1 To sColData): ReDim dicArr(1 To sColRes):  ReDim Res(1 To sColData)
  eRow = Range("A3").CurrentRegion.Row + Range("A3").CurrentRegion.Rows.Count - 1
  ReDim Arr(1 To eRow - 2, 1 To sColRes)
  For j = 1 To sColData
    sArr(j) = Range(Cells(3, j), Cells(Rows.Count, j).End(xlUp)).Value
    Res(j) = Arr
  Next j
  For c = 1 To sColRes
    Set dicArr(c) = CreateObject("scripting.dictionary")
  Next c

  Randomize
  For j = 1 To sColData
    Arr = sArr(j):    sRow = UBound(Arr)
    i = (sRow - 7) \ 2
    sR = Array(0, i, sRow - 7 - i, 5, 2)
    For c = 1 To sColRes
      k = 0
      Do
        ik = Int(Rnd * sRow + 1)
        iKey = Arr(ik, 1)
        If dicArr(c).exists(iKey) = False Then
          k = k + 1
          Res(j)(k, c) = iKey
          dicArr(c).Add iKey, ""
          Arr(ik, 1) = Arr(sRow, 1)
          sRow = sRow - 1
        Else
            For c2 = 1 To c - 1
              If dicArr(c2).exists(iKey) = False Then
                tRes = Res(j)
                For i = 1 To UBound(tRes)
                  tmp = tRes(i, c2)
                  If tmp = Empty Then Exit For
                  If dicArr(c).exists(tmp) = False Then
                    k = k + 1
                    Res(j)(k, c) = tmp
                    dicArr(c).Add tmp, ""
                    Arr(ik, 1) = Arr(sRow, 1)
                    sRow = sRow - 1
                   
                    Res(j)(i, c2) = iKey
                    dicArr(c2).Add iKey, ""
                    dicArr(c2).Remove (tmp)
                    Exit For
                  End If
                Next i
                If tmp <> Empty Then Q = 0: Exit For
              End If
            Next c2
        End If
        Q = Q + 1
        If Q = 1000 Then
          MsgBox ("Tieu Roi, Phai viet code moi chi tiet hon !!!"): Exit Sub
        End If
      Loop Until k = sR(c)
    Next c
  Next j
  Application.ScreenUpdating = False
  Range("E3:T" & eRow).ClearContents
  For j = 1 To sColData
    Cells(3, sColRes * j + 1).Resize(UBound(Res(j)), sColRes) = Res(j)
  Next j
  Application.ScreenUpdating = True
End Sub

Dạ hàm này có bỏ được "Tieu Roi, Phai viet code moi chi tiet hon !!!" không ạ. Bấm nó cứ hiện lên như vậy ạ.