Tạo dãy số ngẫu nhiên không trùng

anhtuan1066 · 7/9/09

Trên diển đàn GPE đã có rất nhiều bài viết nói về vấn đề này!
Tôi cũng đã tham khảo rất nhiều code ở các trang nước ngoài nhưng thấy rằng hầu hết đều viết rất khó hiểu và dài dòng!
Trong 1 dịp tình cờ khi nghiên cứu về Dictionary Object, tôi nhận thấy rằng nó có khả năng làm được điều này mà code lại cực kỳ đơn giản
Thuật toán dựa vào định nghĩa của Dictionary có đoạn: Key là những phần tử duy nhất trong Keys
Tôi đã xây dựng code như sau:

PHP:

Function UniqueRandomNum(Bottom As Long, Top As Long, Amount As Long)
  'Application.Volatile '<--- Neu muon gia tri thay doi khi bam F9
  On Error Resume Next
  If Amount > Top - Bottom + 1 Then Amount = Top - Bottom + 1
  With CreateObject("Scripting.Dictionary")
    Do
      .Add Int(Rnd() * (Top - Bottom + 1)) + Bottom, ""
    Loop Until .Count = Amount
    UniqueRandomNum = WorksheetFunction.Transpose(.Keys)
  End With
End Function

Cú pháp hàm:

PHP:

=UniqueRandomNum(Số nhỏ, Số lớn, bao nhiêu số cần tạo)

Giả sử các bạn muốn tạo ra 30 số ngẩu nhiên không trùng nằm trong khoảng từ 1 đến 100, các bạn làm như sau:
- Quét chọn 30 cell tùy ý theo chiều dọc, chẳng hạn là A1:A30
- Gõ vào thanh Formula công thức =UniqueRandomNum(1,100,30)
- Bấm tổ hợp phím Ctrl + Shift + Enter
Hãy thí nghiệm với đoạn Test sau:

PHP:

Sub Test()
  Range("A1:A30").Value = UniqueRandomNum(1, 100, 30)
End Sub

--------------
Ghi chú: Dictionary Object còn làm được nhiều thứ khác nữa, chẳng hạn có thể xây dựng hàm trích lọc các phần tử duy nhất (ngẫu nhiên và duy nhất đã làm được, đương nhiên duy nhất sẽ càng dể hơn)

HieuCD · 9/10/16

làm thử bạn kiểm tra lại, để tiện cho bạn kiểm tra mình làm thêm sheet2

motnguoiban2020 · 19/10/16

doveandrose đã viết:
giải pháp thì có , nhưng hôm qua tôi đã nhắc nhở 1 lần , cứ từ từ thì cái gì cũng xong , thế mà hôm nay vẫn tiếp tục tái diễn trò spam hối nhau , đã vậy tôi cho chủ đề này trôi luôn . Từ bây giờ đến thứ 2 tuần sau , nếu không ai làm giúp bạn thì tôi mới up file lên nhé , để bạn biết spam hối thúc tôi thì sẽ thế nào .

Mình vẫn đang mong chờ giải pháp của bạn. Nếu có thể hy vọng được bạn hỗ trợ.

doveandrose · 19/10/16

motnguoiban2020 đã viết:
Mình vẫn đang mong chờ giải pháp của bạn. Nếu có thể hy vọng được bạn hỗ trợ.

ủa tôi tưởng bạn tải file #85 xài rồi chứ , không thấy khiếu nại gì thì tôi cứ yên tâm là file #85 sử dụng được . Bạn đã sử dụng file #85 chưa ?

motnguoiban2020 · 19/10/16

doveandrose đã viết:
ủa tôi tưởng bạn tải file #85 xài rồi chứ , không thấy khiếu nại gì thì tôi cứ yên tâm là file #85 sử dụng được . Bạn đã sử dụng file #85 chưa ?

Mình cũng có sử dụng nhưng vẫn không như ý của mình mong muốn. Cảm ơn bạn HieuCD đã hỗ trợ.

doveandrose · 19/10/16

motnguoiban2020 đã viết:
Mình cũng có sử dụng nhưng vẫn không như ý của mình mong muốn

à có khiếu nại thì ta tính tiếp . Bạn cho biết 1 cửa hàng nằm trên nhiều khu vực có thật không ? tôi thấy có vẻ vô lý . Bạn giải thích dùm tôi khúc này

motnguoiban2020 · 19/10/16

doveandrose đã viết:
à có khiếu nại thì ta tính tiếp . Bạn cho biết 1 cửa hàng nằm trên nhiều khu vực có thật không ? tôi thấy có vẻ vô lý . Bạn giải thích dùm tôi khúc này

Khu vực ở đây chỉ là vị trí ngồi thôi bạn, không phải khu vực địa lý. Cửa hàng có nhiều khách thì ngồi ở nhiều khu vực ạ.

doveandrose · 20/10/16

motnguoiban2020 đã viết:
Khu vực ở đây chỉ là vị trí ngồi thôi bạn, không phải khu vực địa lý. Cửa hàng có nhiều khách thì ngồi ở nhiều khu vực ạ.

Nếu 1 khu vực chứa nhiều cửa hàng và 1 cửa hàng cũng nằm trên nhiều khu vực thì đây là bài toán thật sự khó , hoặc có thể là tôi chưa nhìn ra chìa khóa giúp đơn giản hóa vấn đề . Bạn thử chạy file này xem sao

motnguoiban2020 · 20/10/16

Cảm ơn bạn nhiều lắm. Vậy là đã hợp lý rồi ạ

NguyenNgocThuHien · 3/6/17

anhtuan1066 đã viết:
Trên diển đàn GPE đã có rất nhiều bài viết nói về vấn đề này!
Tôi cũng đã tham khảo rất nhiều code ở các trang nước ngoài nhưng thấy rằng hầu hết đều viết rất khó hiểu và dài dòng!
Trong 1 dịp tình cờ khi nghiên cứu về Dictionary Object, tôi nhận thấy rằng nó có khả năng làm được điều này mà code lại cực kỳ đơn giản
Thuật toán dựa vào định nghĩa của Dictionary có đoạn: Key là những phần tử duy nhất trong Keys
Tôi đã xây dựng code như sau:

PHP:

Function UniqueRandomNum(Bottom As Long, Top As Long, Amount As Long) 'Application.Volatile '<--- Neu muon gia tri thay doi khi bam F9 On Error Resume Next If Amount > Top - Bottom + 1 Then Amount = Top - Bottom + 1 With CreateObject("Scripting.Dictionary") Do .Add Int(Rnd() * (Top - Bottom + 1)) + Bottom, "" Loop Until .Count = Amount UniqueRandomNum = WorksheetFunction.Transpose(.Keys) End With End Function

Cú pháp hàm:

PHP:

=UniqueRandomNum(Số nhỏ, Số lớn, bao nhiêu số cần tạo)

Giả sử các bạn muốn tạo ra 30 số ngẩu nhiên không trùng nằm trong khoảng từ 1 đến 100, các bạn làm như sau:
- Quét chọn 30 cell tùy ý theo chiều dọc, chẳng hạn là A1:A30
- Gõ vào thanh Formula công thức =UniqueRandomNum(1,100,30)
- Bấm tổ hợp phím Ctrl + Shift + Enter
Hãy thí nghiệm với đoạn Test sau:

PHP:

Sub Test() Range("A1:A30").Value = UniqueRandomNum(1, 100, 30) End Sub

--------------
Ghi chú: Dictionary Object còn làm được nhiều thứ khác nữa, chẳng hạn có thể xây dựng hàm trích lọc các phần tử duy nhất (ngẫu nhiên và duy nhất đã làm được, đương nhiên duy nhất sẽ càng dể hơn)

Code trên có một điểm yếu mà rất dễ gây treo máy Until .Count = Amount

Nếu Amount=99% * Top và top tương đối lớn thì nó chạy rất là chậm và không ổn định về mặt thời gian. Giả sử top=1000, và amount=999, hàm tìm được 998 giá trị. Khi tìm giá trị cuối cùng thì xác xuất thành công sẽ là (1000-998)/1000, khá nhỏ, nên dễ gây treo máy. Thử nghiệm top=500000 và amount=495000 có khi chạy mất 20s tới 40s.
Với code dưới, nó chạy cực nhanh luôn mà không cần dùng dic hoặc collect.

Mã:

Function UniqueRandomNum2(Bottom As Long, Top As Long, Amount As Long)

    If Top - Bottom + 1 < Amount Or Amount <= 0 Then
        UniqueRandomNum2 = CVErr(xlErrNA)
        Exit Function
    End If
    
    Dim lTemp As Long
    Dim lNum As Long
    Dim lIndex As Long
    Dim lStart As Long
    
    Dim Ar() As Long
    Dim arKq() As Long
    
    lNum = Top - Bottom + 1
    ReDim Ar(1 To lNum) As Long
    ReDim arKq(1 To Amount, 1 To 1) As Long
    
    lStart = Bottom - 1
    For lTemp = 1 To Amount
        Do
            lIndex = 1 + Int(Rnd() * lNum)
        Loop While lNum < lIndex
        
        If Ar(lIndex) = 0 Then
            arKq(lTemp, 1) = lIndex + lStart
        Else
            arKq(lTemp, 1) = Ar(lIndex) + lStart
        End If
        
        If Ar(lNum) = 0 Then
            Ar(lIndex) = lNum
        Else
            Ar(lIndex) = Ar(lNum)
        End If
        lNum = lNum - 1
        
    Next
    
    
      
    
    UniqueRandomNum2 = arKq
 
 
End Function

AutoReply · 3/6/17

NguyenNgocThuHien đã viết:
Code trên có một điểm yếu mà rất dễ gây treo máy Until .Count = Amount

Nếu Amount=99% * Top và top tương đối lớn thì nó chạy rất là chậm và không ổn định về mặt thời gian. Giả sử top=1000, và amount=999, hàm tìm được 998 giá trị. Khi tìm giá trị cuối cùng thì xác xuất thành công sẽ là (1000-998)/1000, khá nhỏ, nên dễ gây treo máy. Thử nghiệm top=500000 và amount=495000 có khi chạy mất 20s tới 40s.
Với code dưới, nó chạy cực nhanh luôn mà không cần dùng dic hoặc collect.

Mã:

Function UniqueRandomNum2(Bottom As Long, Top As Long, Amount As Long) If Top - Bottom + 1 < Amount Or Amount <= 0 Then UniqueRandomNum2 = CVErr(xlErrNA) Exit Function End If Dim lTemp As Long Dim lNum As Long Dim lIndex As Long Dim lStart As Long Dim Ar() As Long Dim arKq() As Long lNum = Top - Bottom + 1 ReDim Ar(1 To lNum) As Long ReDim arKq(1 To Amount, 1 To 1) As Long lStart = Bottom - 1 For lTemp = 1 To Amount Do lIndex = 1 + Int(Rnd() * lNum) Loop While lNum < lIndex If Ar(lIndex) = 0 Then arKq(lTemp, 1) = lIndex + lStart Else arKq(lTemp, 1) = Ar(lIndex) + lStart End If If Ar(lNum) = 0 Then Ar(lIndex) = lNum Else Ar(lIndex) = Ar(lNum) End If lNum = lNum - 1 Next UniqueRandomNum2 = arKq End Function

chào mừng bạn đến châu Mỹ. Nhưng thật tiếc tác giả đề tài này đã cải tiến code rồi. Người ta dùng có 1 vòng lặp thôi bạn ạ.

NguyenNgocThuHien · 3/6/17

AutoReply đã viết:
chào mừng bạn đến châu Mỹ. Nhưng thật tiếc tác giả đề tài này đã cải tiến code rồi. Người ta dùng có 1 vòng lặp thôi bạn ạ.

Dùng bao nhiêu vòng lặp mình nghĩ không quan trọng, thuật toán mới là thứ để nói, vòng lặp Do của mình viết ra cho nó có, chứ hầu như mỗi lần nó chỉ thực hiện duy nhất một lần thôi nhé. Mình cho nó vào để đề phòng những trường hợp do sai số tính toán mà có thể gây lôi.

Mình thì chưa biết code mới như thế nào, nhưng nếu dùng dic thì chưa chắc nhanh đâu nhé, bởi code trên đều thao tác trên mảng.

ndu96081631 · 3/6/17

NguyenNgocThuHien đã viết:
Dùng bao nhiêu vòng lặp mình nghĩ không quan trọng, thuật toán mới là thứ để nói, vòng lặp Do của mình viết ra cho nó có, chứ hầu như mỗi lần nó chỉ thực hiện duy nhất một lần thôi nhé. Mình cho nó vào để đề phòng những trường hợp do sai số tính toán mà có thể gây lôi.

Mình thì chưa biết code mới như thế nào, nhưng nếu dùng dic thì chưa chắc nhanh đâu nhé, bởi code trên đều thao tác trên mảng.

Đề tài này cũng lâu lắm rồi bạn à (năm 2009) và sau đó đã được cải tiến rất nhiều

Mã:

Function UniqueRandNum(ByVal Bottom As Long, ByVal Top As Long, ByVal Amount As Long)
  Dim i As Long, lPos As Long, n As Long, lTmp As Long, idx As Long
  'Application.Volatile '<--- Neu muon gia tri thay doi khi bam F9
  If Top > Bottom Then
    If Amount > Top - Bottom + 1 Then Amount = Top - Bottom + 1
    ReDim arr(Bottom To Top) As Long
    ReDim aDes(1 To Amount, 1 To 1)
    n = Top - Bottom + 1
    For i = 1 To Amount
      idx = n + Bottom - 1
      lPos = Int(Rnd() * n) + Bottom
      If arr(lPos) = 0 Then arr(lPos) = lPos
      If arr(idx) = 0 Then arr(idx) = idx
      aDes(i, 1) = arr(lPos)
      lTmp = arr(lPos): arr(lPos) = arr(idx): arr(idx) = lTmp
      n = n - 1
    Next
    UniqueRandNum = aDes
   End If
End Function

HieuCD · 3/6/17

ndu96081631 đã viết:

Đề tài này cũng lâu lắm rồi bạn à (năm 2009) và sau đó đã được cải tiến rất nhiều

Mã:

Function UniqueRandNum(ByVal Bottom As Long, ByVal Top As Long, ByVal Amount As Long)
  Dim i As Long, lPos As Long, n As Long, lTmp As Long, idx As Long
  'Application.Volatile '<--- Neu muon gia tri thay doi khi bam F9
  If Top > Bottom Then
    If Amount > Top - Bottom + 1 Then Amount = Top - Bottom + 1
    ReDim arr(Bottom To Top) As Long
    ReDim aDes(1 To Amount, 1 To 1)
    n = Top - Bottom + 1
    For i = 1 To Amount
      idx = n + Bottom - 1
      lPos = Int(Rnd() * n) + Bottom
      If arr(lPos) = 0 Then arr(lPos) = lPos
      If arr(idx) = 0 Then arr(idx) = idx
      aDes(i, 1) = arr(lPos)
      lTmp = arr(lPos): arr(lPos) = arr(idx): arr(idx) = lTmp
      n = n - 1
    Next
    UniqueRandNum = aDes
   End If
End Function

Dựa trên code của bạn, bỏ vài lệnh

Mã:

Function UniqueRandom(ByVal Bottom As Long, ByVal Top As Long, ByVal N As Long) As Variant
  Dim Arr() As Long, Darr() As Long, Tmp As Long, i As Long, k As Long, ik As Long
  If Top > Bottom Then
    If N > Top - Bottom + 1 Then N = Top - Bottom + 1
    ReDim Darr(Bottom To Top):      ReDim Arr(1 To N, 1 To 1)
    Randomize
    k = Top - Bottom + 1
    For i = 1 To N
      ik = k + Bottom - 1
      Tmp = Int(Rnd() * k) + Bottom
      If Darr(Tmp) = 0 Then Darr(Tmp) = Tmp
      Arr(i, 1) = Darr(Tmp)
      If Darr(ik) = 0 Then Darr(Tmp) = ik Else Darr(Tmp) = Darr(ik)
      k = k - 1
    Next i
    UniqueRandom = Arr
  End If
End Function

ndu96081631 · 3/6/17

HieuCD đã viết:
Dim Arr() As Long, Darr() As Long, Tmp As Long, i As Long, k As Long, ik As Long

Sao mình ghét mấy cái Darr hay (Sarr) này ghê! Chẳng đúng chuẩn mực tên biến tí nào!
Biết rằng việc đặt tên biến là tùy sở thích, code chạy chính xác vẫn quan trọng hơn. Tuy nhiên, nếu tất cả mọi người đều tuân thủ 1 nguyên tắc chung thì việc đọc code sẽ trở nên rất dễ dàng (liếc qua đã hiểu)
Các bạn có tưởng tượng ngày nào đó chúng ta lập nhóm viết phần mềm rồi trưởng dự án giao cho mỗi người viết 1 module... Khi ấy mà mỗi người viết mỗi kiểu thì đố mà kiểm tra được đấy (được cũng mất rất nhiều thời gian)
Trên mạng người ta kháo nhau rằng: 1 người Việt Nam có thể giỏi hơn 1 người Nhật hoặc Hàn Quốc nhưng 10 người Việt Nam cộng lại thì.. dở ẹc. Tôi tin rằng người ta đang muốn nói đến vấn đề làm việc nhóm
Hãy tham khảo các trang lập trình nước ngoài (nhất là trang từ MS) hoặc đọc tài liệu về các hàm API, các bạn sẽ thấy người ta viết rất chuẩn mực (ngay từ khâu đặt tên biến)
Với người mới tập tành VBA tôi không đề cập, riêng bạn hieuCD (và nhiều bạn khác) đã giỏi lắm rồi, cũng đến lúc các bạn nên chăm chút cho các phần mà tôi đề cập ở trên đi là vừa
Nếu ý kiến cá nhân tôi có làm mích lòng ai đó thì xem như tôi chưa nói gì (tại thấy... ngứa miệng chút)

HieuCD · 3/6/17

ndu96081631 đã viết:
Sao mình ghét mấy cái Darr hay (Sarr) này ghê! Chẳng đúng chuẩn mực tên biến tí nào!
Biết rằng việc đặt tên biến là tùy sở thích, code chạy chính xác vẫn quan trọng hơn. Tuy nhiên, nếu tất cả mọi người đều tuân thủ 1 nguyên tắc chung thì việc đọc code sẽ trở nên rất dễ dàng (liếc qua đã hiểu)
Các bạn có tưởng tượng ngày nào đó chúng ta lập nhóm viết phần mềm rồi trưởng dự án giao cho mỗi người viết 1 module... Khi ấy mà mỗi người viết mỗi kiểu thì đố mà kiểm tra được đấy (được cũng mất rất nhiều thời gian)
Trên mạng người ta kháo nhau rằng: 1 người Việt Nam có thể giỏi hơn 1 người Nhật hoặc Hàn Quốc nhưng 10 người Việt Nam cộng lại thì.. dở ẹc. Tôi tin rằng người ta đang muốn nói đến vấn đề làm việc nhóm
Hãy tham khảo các trang lập trình nước ngoài (nhất là trang từ MS) hoặc đọc tài liệu về các hàm API, các bạn sẽ thấy người ta viết rất chuẩn mực (ngay từ khâu đặt tên biến)
Với người mới tập tành VBA tôi không đề cập, riêng bạn hieuCD (và nhiều bạn khác) đã giỏi lắm rồi, cũng đến lúc các bạn nên chăm chút cho các phần mà tôi đề cập ở trên đi là vừa
Nếu ý kiến cá nhân tôi có làm mích lòng ai đó thì xem như tôi chưa nói gì (tại thấy... ngứa miệng chút)

Do quen thôi, mới đầu chép code của các bạn trên diễn đàn rồi viết theo, riết thành quen nhìn là biết tác dụng của các biến, cũng đổi cách đặt biến mấy lần nhưng cuối code nhìn không ra
Viết code vui thôi, chỉ có mấy lệnh xào tới xào lui là hết vốn
chúc bạn 1 tối vui

NguyenNgocThuHien · 3/6/17

ndu96081631 đã viết:

Đề tài này cũng lâu lắm rồi bạn à (năm 2009) và sau đó đã được cải tiến rất nhiều

Mã:

Function UniqueRandNum(ByVal Bottom As Long, ByVal Top As Long, ByVal Amount As Long)
  Dim i As Long, lPos As Long, n As Long, lTmp As Long, idx As Long
  'Application.Volatile '<--- Neu muon gia tri thay doi khi bam F9
  If Top > Bottom Then
    If Amount > Top - Bottom + 1 Then Amount = Top - Bottom + 1
    ReDim arr(Bottom To Top) As Long
    ReDim aDes(1 To Amount, 1 To 1)
    n = Top - Bottom + 1
    For i = 1 To Amount
      idx = n + Bottom - 1
      lPos = Int(Rnd() * n) + Bottom
      If arr(lPos) = 0 Then arr(lPos) = lPos
      If arr(idx) = 0 Then arr(idx) = idx
      aDes(i, 1) = arr(lPos)
      lTmp = arr(lPos): arr(lPos) = arr(idx): arr(idx) = lTmp
      n = n - 1
    Next
    UniqueRandNum = aDes
   End If
End Function

Nhưng hàm này vẫn bị lỗi, lỗi rất khó phát hiện.

concogia · 5/6/17

Đề tài này có từ năm 2009, năm mình mới gia nhập diễn đàn, đọc xong code của thầy Ndu mình thấy ....một đống đom đóm trước mặt, ngứa miệng ...hét
Em đi RỪNG CHƯA THAY LÁ
Đến bi giờ võ vẽ được tí code, đọc xong bài #97 của bạn Hiếu CD lại ngứa miệng....hét:
Em về RỪNG LÁ CHƯA THAY
Híc
Bi giờ ( lại bi giờ) tui xin hỏi các thầy, các chú & các anh trong hội Người Cao Tuổi ở GPE viết bài này ( Tạo dãy số ngẫu nhiên không trùng) kiểu nào ( với điều kiện số lần lặp để lấy ngẫu nhiên ít nhất) để khỏi bị lỗi như bài #100, Ai viết được sẽ....có thưởng (Bác Sa, Ba Tê thì thưởng 1 xị "gụ", anh em khác thưởng tượng trưng 2 lon bia (tự chọn)
Thân

doveandrose · 6/6/17

concogia đã viết:
Đề tài này có từ năm 2009, năm mình mới gia nhập diễn đàn, đọc xong code của thầy Ndu mình thấy ....một đống đom đóm trước mặt, ngứa miệng ...hét
Em đi RỪNG CHƯA THAY LÁ
Đến bi giờ võ vẽ được tí code, đọc xong bài #97 của bạn Hiếu CD lại ngứa miệng....hét:
Em về RỪNG LÁ CHƯA THAY
Híc
Bi giờ ( lại bi giờ) tui xin hỏi các thầy, các chú & các anh trong hội Người Cao Tuổi ở GPE viết bài này ( Tạo dãy số ngẫu nhiên không trùng) kiểu nào ( với điều kiện số lần lặp để lấy ngẫu nhiên ít nhất) để khỏi bị lỗi như bài #100, Ai viết được sẽ....có thưởng (Bác Sa, Ba Tê thì thưởng 1 xị "gụ", anh em khác thưởng tượng trưng 2 lon bia (tự chọn)
Thân

vậy là kèo này chỉ dành cho các bậc cha chú thôi. Các thiếu nhi chưa đủ tuổi chỉ được phép ngồi nhìn các bô lão "nhậu".

HieuCD · 6/6/17

concogia đã viết:
Đề tài này có từ năm 2009, năm mình mới gia nhập diễn đàn, đọc xong code của thầy Ndu mình thấy ....một đống đom đóm trước mặt, ngứa miệng ...hét
Em đi RỪNG CHƯA THAY LÁ
Đến bi giờ võ vẽ được tí code, đọc xong bài #97 của bạn Hiếu CD lại ngứa miệng....hét:
Em về RỪNG LÁ CHƯA THAY
Híc
Bi giờ ( lại bi giờ) tui xin hỏi các thầy, các chú & các anh trong hội Người Cao Tuổi ở GPE viết bài này ( Tạo dãy số ngẫu nhiên không trùng) kiểu nào ( với điều kiện số lần lặp để lấy ngẫu nhiên ít nhất) để khỏi bị lỗi như bài #100, Ai viết được sẽ....có thưởng (Bác Sa, Ba Tê thì thưởng 1 xị "gụ", anh em khác thưởng tượng trưng 2 lon bia (tự chọn)
Thân

Nạp 1/2 xị nếp Long An, nắn lại gân cốt, thử sức xem sao

Mã:

Function UniqueRandom(ByVal Bottom As Long, ByVal Top As Long, ByVal N As Long) As Variant
  Dim Arr() As Long, Darr() As Variant, Tmp As Long, i As Long, k As Long
  If Top > Bottom Then
    If N > Top - Bottom + 1 Then N = Top - Bottom + 1
    ReDim Darr(1 To Top - Bottom + 1):  ReDim Arr(1 To N, 1 To 1)
    k = Top - Bottom + 1
    For i = 1 To N
      Tmp = Int(Rnd() * k) + 1
      If Darr(Tmp) = "" Then Darr(Tmp) = Tmp + Bottom - 1
      Arr(i, 1) = Darr(Tmp)
      If Darr(k) = "" Then Darr(Tmp) = k + Bottom - 1 Else Darr(Tmp) = Darr(k)
      k = k - 1
    Next i
    UniqueRandom = Arr
  End If
End Function

Nếu lỡ được thưởng, xin được phép chia cho anh chị trong hội người cao tuổi GPE :pimp:

chúc các bạn một ngày vui /-*+/

mesavn04 · 26/7/17

Không hiểu sao em dùng hàm của Thầy ndu vẫn bị lỗi trùng số. Em có sưu tầm được hàm ESPshuffle rất hay, tốc độ thì khỏi bàn, mà thử nhiều lần vẫn chưa lần nào bị trùng số. Em gửi kèm theo đây để các thầy tham khảo và cho ý kiến

Mã:

 Sub ESPshuffle(ByRef r As Range)
   ' fill the given range with unique random numbers 1..n
   ' where n is the number of cells of the range
   ' 2015-09-20 E/S/P
   ' algorithm: preset a collection with indices 1..n (= unique)
   ' and preserve uniqueness when selecting index at random

   Dim n As Long, nrows As Long, ncols As Long
   Dim i As Long, j As Long, idx As Long
   Dim values() As Long
   Dim arr As Variant

   arr = r  ' range to array, cell content doesnt matter
   nrows = UBound(arr, 1)
   ncols = UBound(arr, 2)
   n = nrows * ncols
   ' preset values, non-random, so unique
   ReDim values(1 To n)
   For i = 1 To n
       values(i) = i
   Next i

   Randomize
   For i = 1 To nrows
       For j = 1 To ncols
           ' choose a random element/index AMONG the remaining
           idx = Int(n * Rnd + 1) ' index in 1..n
           arr(i, j) = values(idx)
           ' remove that element =
           ' preserve the last element in array, then shorten it by 1
           values(idx) = values(n)
           n = n - 1
       Next j
   Next i

   ' fill cells in sheet
   r = arr
End Sub
Nguồn: [URL]https://stackoverflow.com/questions/32674682/generate-truly-random-numbers-in-range-of-cells-using-vba[/URL]

Tạo dãy số ngẫu nhiên không trùng

Thành viên gạo cội

File đính kèm

Chuyên gia GPE

File đính kèm

Thành viên chính thức

hello

Thành viên chính thức

hello

Thành viên chính thức

hello

File đính kèm

Thành viên chính thức

Cute Black Cat

File đính kèm

Thành viên tiêu biểu

Cute Black Cat

Huyền thoại GPE

Chuyên gia GPE

Huyền thoại GPE

Chuyên gia GPE

Cute Black Cat

Gội rồi mới Cạo

hello

Chuyên gia GPE

Thành viên mới

Facebook

Group