lehoanghoc91
Thành viên mới
- Tham gia
- 3/1/20
- Bài viết
- 5
- Được thích
- 4
Sub PickNamesAtRandom()
Dim rNum As Integer, Nums As Double
Nums = [A9].CurrentRegion.Rows.Count
Randomize: rNum = 2 + Nums * Rnd() \ 2
ReDim Arr(1 To 5, 1 To 1): Arr() = Cells(rNum, "A").Resize(5).Value
For rNum = 1 To 5
For Nums = 1 To (3 * 10 ^ 7)
Next Nums
Cells(5 + rNum, "D").Value = Arr(rNum, 1)
Cells(5 + rNum, "D").Interior.ColorIndex = 34 + 9 * Rnd() \ 1
Next rNum
End Sub
Sub PickNamesAtRandom()
Dim SLg As Long, Rws As Long, J As Long, DD As Byte, Tmp As Integer, Dg As Integer
Dim StrC As String
On Error Resume Next
Rws = [A2].CurrentRegion.Rows.Count
For J = 2 To Rws
StrC = StrC & Right("00" & CStr(J), 3)
Next J
Randomize: SLg = Rws * Rnd() \ 2
[D5].CurrentRegion.Offset(1).Clear
For J = 1 To SLg
DD = (Len(StrC) * Rnd() \ 1) - 3
If DD Mod 3 = 0 Then
DD = DD + 1
ElseIf DD Mod 3 = 2 Then
DD = DD - 1
ElseIf DD < 1 Then
DD = 1
End If
StrC = Left(StrC, DD - 1) & Mid(StrC, DD + 3, Len(StrC))
Dg = Mid(StrC, DD, 3)
Cells(5, "D").Offset(J).Value = Cells(Dg, "A").Value
For Rws = 1 To 10 ^ 3
Cells(5, "D").Offset(J).Interior.ColorIndex = 34 + 9 * Rnd() \ 1
Next Rws
Next J
End Sub
Thêm dòng code sau vào dưới Next ArI (khi nhấn nút nó sẽ đọc).Cám ơn bạn nhưng nó trở thành chọn ngẫu nhiên 5 người liên tiếp mất rồi.
View attachment 230908
Code rất hay , đáng để nghiên cứu lắm bạn, cám ơn bạn rất nhiều.PHP:Sub PickNamesAtRandom() Dim SLg As Long, Rws As Long, J As Long, DD As Byte, Tmp As Integer, Dg As Integer Dim StrC As String On Error Resume Next Rws = [A2].CurrentRegion.Rows.Count For J = 2 To Rws StrC = StrC & Right("00" & CStr(J), 3) Next J Randomize: SLg = Rws * Rnd() \ 2 [D5].CurrentRegion.Offset(1).Clear For J = 1 To SLg DD = (Len(StrC) * Rnd() \ 1) - 3 If DD Mod 3 = 0 Then DD = DD + 1 ElseIf DD Mod 3 = 2 Then DD = DD - 1 ElseIf DD < 1 Then DD = 1 End If StrC = Left(StrC, DD - 1) & Mid(StrC, DD + 3, Len(StrC)) Dg = Mid(StrC, DD, 3) Cells(5, "D").Offset(J).Value = Cells(Dg, "A").Value For Rws = 1 To 10 ^ 3 Cells(5, "D").Offset(J).Interior.ColorIndex = 34 + 9 * Rnd() \ 1 Next Rws Next J End Sub
cám ơn bạn, có vẻ ổn hơn rồi.Thêm dòng code sau vào dưới Next ArI (khi nhấn nút nó sẽ đọc).
Range("D6").Speak
Option Explicit
Function Draw(ByVal number As Long, ByVal amount As Long)
Dim index As Long, k As Long, Arr(), a As Long
If amount > number Then Exit Function
ReDim Arr(1 To number)
For k = 1 To number
Arr(k) = k
Next k
Randomize
For k = 1 To amount
index = Int(Rnd * (number - k + 1)) + k
a = Arr(k)
Arr(k) = Arr(index)
Arr(index) = a
Next k
ReDim Preserve Arr(1 To amount)
Draw = Arr
End Function
Sub animate()
Dim lastRow As Long, r As Long, c As Long, amount As Long, text As String, data(), Arr, t
With ThisWorkbook.Worksheets("Sheet1")
' xoa ket qua cu
lastRow = .Cells(Rows.Count, "D").End(xlUp).Row
If lastRow >= 6 Then .Range("D6:D" & lastRow).ClearContents
' so ten can lay
amount = .Range("D3").Value
If amount < 1 Then Exit Sub
' lay cac ten vao mang
lastRow = .Cells(Rows.Count, "A").End(xlUp).Row
If lastRow - 2 < amount Then Exit Sub
data = .Range("A2:A" & lastRow).Value
End With
' chon amount chi so vao mang Arr
Arr = Draw(UBound(data), amount)
lastRow = 6
For r = 1 To UBound(Arr)
' chi so xac dinh ten trong mang data
text = data(Arr(r), 1)
c = 1
With ThisWorkbook.Worksheets("Sheet1")
Do While c <= Len(text)
t = Timer + 0.2 ' neu nhanh qua thi tang 0.2, neu cham qua thi giam
Do Until Timer > t
DoEvents
Loop
.Range("D" & lastRow).Value = Mid(text, 1, c)
c = c + 1
Loop
End With
lastRow = lastRow + 1
Next r
End Sub
Bạn thử nghiệm code nhưng bạn không chú ý đến vị trí code thực hiện thế nào?Code rất hay , đáng để nghiên cứu lắm bạn, cám ơn bạn rất nhiều.
Cám ơn bạn, có vẻ ổn hơn rồi.
Bạn thử với cùi bắp này
PHP:Sub PickNamesAtRandom() Dim rNum As Integer, Nums As Double Nums = [A9].CurrentRegion.Rows.Count Randomize: rNum = 2 + Nums * Rnd() \ 2 ReDim Arr(1 To 5, 1 To 1): Arr() = Cells(rNum, "A").Resize(5).Value For rNum = 1 To 5 For Nums = 1 To (3 * 10 ^ 7) Next Nums Cells(5 + rNum, "D").Value = Arr(rNum, 1) Cells(5 + rNum, "D").Interior.ColorIndex = 34 + 9 * Rnd() \ 1 Next rNum End Sub
Cám ơn bạn nhiều, để mình nghiên cứu tiếp.Già rồi nên nhìn đèn neon nhức mắt quá. Lại vừa hỏng cái loa.
Thôi thì chơi máy chữ vậy.
Hàm Draw là tổng quát, dùng trong nhiều trường hợp - dùng khi cần chọn amount giá trị từ number giá trị (số hoặc chữ).
Dữ liệu từ A2, số cần chọn tại D3, kết quả từ D6.
Mã:Option Explicit Function Draw(ByVal number As Long, ByVal amount As Long) Dim index As Long, k As Long, Arr(), a As Long If amount > number Then Exit Function ReDim Arr(1 To number) For k = 1 To number Arr(k) = k Next k Randomize For k = 1 To amount index = Int(Rnd * (number - k + 1)) + k a = Arr(k) Arr(k) = Arr(index) Arr(index) = a Next k ReDim Preserve Arr(1 To amount) Draw = Arr End Function Sub animate() Dim lastRow As Long, r As Long, c As Long, amount As Long, text As String, data(), Arr, t With ThisWorkbook.Worksheets("Sheet1") ' xoa ket qua cu lastRow = .Cells(Rows.Count, "D").End(xlUp).Row If lastRow >= 6 Then .Range("D6:D" & lastRow).ClearContents ' so ten can lay amount = .Range("D3").Value If amount < 1 Then Exit Sub ' lay cac ten vao mang lastRow = .Cells(Rows.Count, "A").End(xlUp).Row If lastRow - 2 < amount Then Exit Sub data = .Range("A2:A" & lastRow).Value End With ' chon amount chi so vao mang Arr Arr = Draw(UBound(data), amount) lastRow = 6 For r = 1 To UBound(Arr) ' chi so xac dinh ten trong mang data text = data(Arr(r), 1) c = 1 With ThisWorkbook.Worksheets("Sheet1") Do While c <= Len(text) t = Timer + 0.2 ' neu nhanh qua thi tang 0.2, neu cham qua thi giam Do Until Timer > t DoEvents Loop .Range("D" & lastRow).Value = Mid(text, 1, c) c = c + 1 Loop End With lastRow = lastRow + 1 Next r End Sub
Hi anh, em sử dụng code trên thấy rất hay, em còn 1 chỗ nếu có thể anh giúp em với.Già rồi nên nhìn đèn neon nhức mắt quá. Lại vừa hỏng cái loa.
Thôi thì chơi máy chữ vậy.
Hàm Draw là tổng quát, dùng trong nhiều trường hợp - dùng khi cần chọn amount giá trị từ number giá trị (số hoặc chữ).
Dữ liệu từ A2, số cần chọn tại D3, kết quả từ D6.
Mã:Option Explicit Function Draw(ByVal number As Long, ByVal amount As Long) Dim index As Long, k As Long, Arr(), a As Long If amount > number Then Exit Function ReDim Arr(1 To number) For k = 1 To number Arr(k) = k Next k Randomize For k = 1 To amount index = Int(Rnd * (number - k + 1)) + k a = Arr(k) Arr(k) = Arr(index) Arr(index) = a Next k ReDim Preserve Arr(1 To amount) Draw = Arr End Function Sub animate() Dim lastRow As Long, r As Long, c As Long, amount As Long, text As String, data(), Arr, t With ThisWorkbook.Worksheets("Sheet1") ' xoa ket qua cu lastRow = .Cells(Rows.Count, "D").End(xlUp).Row If lastRow >= 6 Then .Range("D6:D" & lastRow).ClearContents ' so ten can lay amount = .Range("D3").Value If amount < 1 Then Exit Sub ' lay cac ten vao mang lastRow = .Cells(Rows.Count, "A").End(xlUp).Row If lastRow - 2 < amount Then Exit Sub data = .Range("A2:A" & lastRow).Value End With ' chon amount chi so vao mang Arr Arr = Draw(UBound(data), amount) lastRow = 6 For r = 1 To UBound(Arr) ' chi so xac dinh ten trong mang data text = data(Arr(r), 1) c = 1 With ThisWorkbook.Worksheets("Sheet1") Do While c <= Len(text) t = Timer + 0.2 ' neu nhanh qua thi tang 0.2, neu cham qua thi giam Do Until Timer > t DoEvents Loop .Range("D" & lastRow).Value = Mid(text, 1, c) c = c + 1 Loop End With lastRow = lastRow + 1 Next r End Sub
Option Explicit
Sub PickNamesAtRandom()
Dim SLg As Long, Rws As Long, J As Long, DD As Byte, Tmp As Integer, Dg As Integer
Dim StrC As String, sNum As String: Dim Rng As Range, sRng As Range
On Error Resume Next
Rws = [A2].CurrentRegion.Rows.Count: Set Rng = [D5].CurrentRegion
For J = 2 To Rws
sNum = Cells(J, "A").Value
Set sRng = Rng.Find(sNum, , xlFormulas, xlWhole)
If sRng Is Nothing Then
If J Mod 2 = 0 Then
StrC = StrC & Right("00" & CStr(J), 3)
Else
StrC = Right("00" & CStr(J), 3) & StrC
End If
End If
Next J
Randomize: SLg = 4 + Len(StrC) * Rnd() \ 2
[D5].CurrentRegion.Offset(1).Clear
For J = 1 To SLg Step 3
[D999].End(xlUp).Offset(1).Value = Cells(CInt(Mid(StrC, J, 3)), "A").Value
[D999].End(xlUp).Interior.ColorIndex = 34 + 9 * Rnd() \ 1
Application.Wait Now + 10 ^ (-5.23)
Next J
[D3].Value = J \ 3
End Sub
DIỄN ĐÀN GIẢI PHÁP EXCEL Group 1
DIỄN ĐÀN GIẢI PHÁP EXCEL Group 2