Đảo vị trí các số ngẫu nhiên và copy kết quả . (1 người xem)

[nggiahoang]

Đảo số ngẫu nhiên sau mỗi lần nhấn nút thực hiện,sau đó copy kết quả sang sheet kế bên.

Sau mỗi lần bấm vào nút “ thực hiện “ thì tất cả những con số được bao trong khung màu sẽ tự động đổi chỗ ngẫu nhiên cho nhau, mà không vượt ra khỏi các ô tô màu theo quy định ( tương tự như sort nhưng khác ở chỗ sort thì theo thứ tự tăng giảm dần còn ở đây thì nhảy tự do).

Để làm được việc này thì chỉ có VBA ; em nhờ các anh chị viết code giùm .Cám ơn !

 

[nggiahoang]

Gọi đò ơi, gọi đò ơi... ai đưa tôi qua đò, ơi hỡi đò ơi!


Gọi đò ơi! Cớ sao không có ai đưa đò
Để con đò buồn hiu quạnh bến quê

................

 

[ndu96081631]

Gọi đò ơi, gọi đò ơi... ai đưa tôi qua đò, ơi hỡi đò ơi!


Gọi đò ơi! Cớ sao không có ai đưa đò
Để con đò buồn hiu quạnh bến quê

................

Bài toán đảo ngẫu nhiên này chẳng phải khó khăn gì cả, có điều nhìn "đám rừng" dữ liệu của bạn thấy oải quá
Tôi cho bạn hàm này do anh siwtom viết:

Function Draw(ByVal Arr, ByVal Amount As Long)
  Application.Volatile
  Dim index As Long, k As Long, d As Long, c As Long, tmpArr, original
  If Amount > UBound(Arr) - LBound(Arr) + 1 Then Exit Function
  original = Arr
  ReDim tmpArr(1 To Amount, 1 To 1)
  d = LBound(original)
  c = UBound(original)
  Randomize
  For k = 1 To Amount
    index = Int(Rnd() * (c - d + 1)) + d
    tmpArr(k, 1) = original(index)
    original(index) = original(k + LBound(original) - 1)
    d = d + 1
  Next k
  Draw = tmpArr
End Function

Bạn "ráp" vào file thế nào tùy bạn nhé

 

[nggiahoang]

Gởi GPE lần 2

Cám ơn anh NDU ! lúc đầu em có dự định đưa lên ít mẫu nhưng rồi sợ các anh chị lại trách sao không đưa lên hết ,làm rồi lại sửa nữa ....

Thôi thì em rút lại ngắn gọn lại chỉ còn 6 cột dãy số được tô màu . Nhờ cao thủ GPE ra tay ráp luôn vì e không rành VBA.

 

[ndu96081631]

Cám ơn anh NDU ! lúc đầu em có dự định đưa lên ít mẫu nhưng rồi sợ các anh chị lại trách sao không đưa lên hết ,làm rồi lại sửa nữa ....

Thôi thì em rút lại ngắn gọn lại chỉ còn 6 cột dãy số được tô màu . Nhờ cao thủ GPE ra tay ráp luôn vì e không rành VBA.

Làm thử cho bạn 1 cái copy vùng D814 từ sheet1 sang sheet2

Sub Main()
  Dim arr, [COLOR=#ff0000]rng1[/COLOR] As Range
  Set [COLOR=#ff0000]rng1[/COLOR] = Sheet1.Range("[COLOR=#ff0000]D8:D14[/COLOR]")
  arr = Draw(WorksheetFunction.Transpose([COLOR=#ff0000]rng1[/COLOR]), [COLOR=#ff0000]rng1[/COLOR].Count)
  Sheet2.Range([COLOR=#ff0000]rng1[/COLOR].Address).Value = arr
End Sub
Function Draw(ByVal arr, ByVal Amount As Long)
  Application.Volatile
  Dim index As Long, k As Long, d As Long, c As Long, tmpArr, original
  If Amount > UBound(arr) - LBound(arr) + 1 Then Exit Function
  original = arr
  ReDim tmpArr(1 To Amount, 1 To 1)
  d = LBound(original)
  c = UBound(original)
  Randomize
  For k = 1 To Amount
    index = Int(Rnd() * (c - d + 1)) + d
    tmpArr(k, 1) = original(index)
    original(index) = original(k + LBound(original) - 1)
    d = d + 1
  Next k
  Draw = tmpArr
End Function

Chạy Sub Main sẽ có kết quả
Những vùng dữ liệu khác làm tương tự. Ví dụ vùng F8:F31 ta viết thế này:

Sub Main()
  Dim arr, [COLOR=#ff0000]rng2[/COLOR] As Range
  Set [COLOR=#ff0000]rng2[/COLOR] = Sheet1.Range("[COLOR=#ff0000]F8:F31[/COLOR]")
  arr = Draw(WorksheetFunction.Transpose([COLOR=#ff0000]rng2[/COLOR]), [COLOR=#ff0000]rng2[/COLOR].Count)
  Sheet2.Range([COLOR=#ff0000]rng2[/COLOR].Address).Value = arr
End Sub

 

[nggiahoang]

Làm thử cho bạn 1 cái copy vùng D814 từ sheet1 sang sheet2

Chạy Sub Main sẽ có kết quả
Những vùng dữ liệu khác làm tương tự. Ví dụ vùng F8:F31 ta viết thế này:

End Sub[/code]

Sub main là cái nào hả anh NDU ? Bấm vào đâu để chạy ?

Nhìn code như e lạc vào giữa rừng , có mấy cái chữ đỏ đỏ thì em hiểu và thay được .Vậy anh làm mẫu giúp e vào cái file em đã gởi lên lần 2 “ rút gọn còn 6 cột “ với. Sau đó em sẽ tùy biến vào những cái khác .

Ngoài ra cho em hỏi luôn là dùng hàm nào để trả về kết quả :

màu xanh ( từ….. đến … ) : Trung bình

màu tím ( từ….. đến … ) : Khá

màu đỏ ( từ… ) : Giỏi

Cám ơn anh !

 

[sealand]

Mình tham gia 1 code như sau:

Sub Main()
Dim Tmp(), Tmp1(), k
Tmp1 = Array("D8:D14", "F8:F31", "H8:H33", "J8:J15", "L8:L31", "N8:N33")
For k = 0 To UBound(Tmp1)
Tmp = WorksheetFunction.Transpose(Sheet1.Range(Tmp1(k)))
Sheet2.Cells(1, k + 1).Resize(UBound(Tmp)) = WorksheetFunction.Transpose(Transpos(Tmp))
Next
End Sub
'----------------------------------------------------------------------------------------
Function Transpos(Arr() As Variant)
Dim Tm(), Kq(), i, j
Tm = Arr
Do
i = i + 1
j = ItemRnd(UBound(Tm))
ReDim Preserve Kq(1 To i)
Kq(i) = Tm(j)
If UBound(Tm) = 1 Then Exit Do
Tm(j) = Tm(UBound(Tm))
ReDim Preserve Tm(1 To UBound(Tm) - 1)
Loop
Transpos = Kq
End Function
'----------------------------------------------------------------------------
Function ItemRnd(Ltd As Long)
Dim Tm1, Tm2, i
For i = 1 To Ltd
Tm1 = Rnd()
If Tm1 > Tm2 Then Tm2 = Tm1: ItemRnd = i
Next
End Function

 

[sealand]

Dùng thủ thuật:


Int((Hi - Lo + 1) * Rnd + Lo) Tương đương Randbetween(Lo,Hi)



Thay thế Code bớt 1 hàm và gọn hơn

Sub Main()
Dim Tmp(), Tmp1(), k
Tmp1 = Array("D8:D14", "F8:F31", "H8:H33", "J8:J15", "L8:L31", "N8:N33")
For k = 0 To UBound(Tmp1)
Tmp = WorksheetFunction.Transpose(Sheet1.Range(Tmp1(k)))
Sheet2.Cells(1, k + 1).Resize(UBound(Tmp)) = WorksheetFunction.Transpose(Transpos(Tmp))
Next
End Sub
'-------------------------------------------------------
Function Transpos(Arr() As Variant)
Dim Tm(), Kq(), i, j
Tm = Arr
Do
i = i + 1
[COLOR=#ff0000][B]j = Int(UBound(Tm) * Rnd + 1)[/B][/COLOR]
ReDim Preserve Kq(1 To i)
Kq(i) = Tm(j)
If UBound(Tm) = 1 Then Exit Do
Tm(j) = Tm(UBound(Tm))
ReDim Preserve Tm(1 To UBound(Tm) - 1)
Loop
Transpos = Kq
End Function

 

[nggiahoang]

file gởi kèm phần ví dụ

 

[sealand]

Trên mỗi cột em đều có chừa cột trống dùng để tạo công thức xếp loại , code của anh Sealand khi copy sang thì số liệu đổi chỗ nhau rất tốt nhưng các cột xếp liền kề nhau .

Bạn để ý Code sau:

Sub Main()
 Dim Tmp(), Tmp1(), k
 Tmp1 = Array("D8:D14", "F8:F31", "H8:H33", "J8:J15", "L8:L31", "N8:N33")
 For k = 0 To UBound(Tmp1)
 Tmp = WorksheetFunction.Transpose(Sheet1.Range(Tmp1(k)))
 Sheet2.Cells(1, [SIZE=4][B][COLOR=#ff0000]k + 1[/COLOR][/B][/SIZE]).Resize(UBound(Tmp)) = WorksheetFunction.Transpose(Transpos(Tmp))
 Next
 End Sub

Muốn cách bao nhiêu cột thì thay con số k+1 màu đỏ thành (k+1)*n . Ví dụ (k+1)*2 thì cách 1 cột.
Thậm chí bạn muốn đặt nó ở đâu là tuỳ bạn chứ.