Nhờ chỉ giáo cách tạo hiệu ứng khi trả về kết quả

lehoanghoc91 · 7/1/20

Em có 1 danh sách , một ô chọn số lượng và một button, khi nhấn button sẽ hiện ra ngẫu nhiên số lượng tên đã chọn .
Nhưng kết quả xảy ra quá nhanh em muốn tạo một hiệu ứng gì đó để người xem cảm giác tin tưởng hơn ạ, nhờ các cao nhân chỉ giáo giúp em.

SA_DQ · 7/1/20

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

lehoanghoc91 · 7/1/20

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.

Nguyễn Hồng Quang · 7/1/20

Bạn tạo 1 userform, rồi đặt thời gian xuất hiện là 1-2 giây. Khi ra kết quả thì cho hiệu ứng là hiện userform

SA_DQ · 7/1/20

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

VetMini · 7/1/20

Tưởng gì chứ la làng thì quá dễ.
Cứ việc ra một cái MsgBox, bảo nó bíp một tiếng.

Muốn la làng to hơn thì dùng code này, nó sẽ bíp 10 cái trong vòng 1 giây
For i = 1 to 10
Beep
Application.Wait Now + 1.0/(24*60*60*10)
Next i

be_09 · 7/1/20

lehoanghoc91 đã viết:
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

Thêm dòng code sau vào dưới Next ArI (khi nhấn nút nó sẽ đọc).

Range("D6").Speak

lehoanghoc91 · 7/1/20

SA_DQ đã viết:

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

Code rất hay , đáng để nghiên cứu lắm bạn, cám ơn bạn rất nhiều.

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

be09 đã viết:
Thêm dòng code sau vào dưới Next ArI (khi nhấn nút nó sẽ đọc).

Range("D6").Speak

cám ơn bạn, có vẻ ổn hơn rồi.

batman1 · 8/1/20

Già rồi nên nhìn đèn neon nhức mắt quá. Lại vừa hỏng cái loa.

Thôi thì chơi máy chữ vậy.

Hàm Draw là tổng quát, dùng trong nhiều trường hợp - dùng khi cần chọn amount giá trị từ number giá trị (số hoặc chữ).

Dữ liệu từ A2, số cần chọn tại D3, kết quả 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

be_09 · 8/1/20

lehoanghoc91 đã viết:
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ử nghiệm code nhưng bạn không chú ý đến vị trí code thực hiện thế nào?
1/ Vị trí code trên nó chỉ thực hiện đọc trước khi hiện kết quả và chỉ đọc có 1 Cell.
2/ Muốn đọc nhiều Cell bạn thêm vào một tí thôi, sửa code lại thế này và cho vào trước End Sub nó sẽ hiện kết quả rồi mới thực hiện việc đọc.

Range("D6: D8").Speak

lehoanghoc91 · 8/1/20

SA_DQ đã viết:

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

batman1 đã viết:

Già rồi nên nhìn đèn neon nhức mắt quá. Lại vừa hỏng cái loa.

Thôi thì chơi máy chữ vậy.

Hàm Draw là tổng quát, dùng trong nhiều trường hợp - dùng khi cần chọn amount giá trị từ number giá trị (số hoặc chữ).

Dữ liệu từ A2, số cần chọn tại D3, kết quả 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

Cám ơn bạn nhiều, để mình nghiên cứu tiếp.

lehoanghoc91 · 11/1/20

batman1 đã viết:

Già rồi nên nhìn đèn neon nhức mắt quá. Lại vừa hỏng cái loa.

Thôi thì chơi máy chữ vậy.

Hàm Draw là tổng quát, dùng trong nhiều trường hợp - dùng khi cần chọn amount giá trị từ number giá trị (số hoặc chữ).

Dữ liệu từ A2, số cần chọn tại D3, kết quả 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.

- Khi chọn lần đầu ra 10 người , thì các lần khác không chọn ra 10 người đó nữa được không anh.

Nhờ anh chỉ giúp em nhé.

SA_DQ · 13/1/20

Bạn xài macro này cho iêu cầu của bạn:

PHP:

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

Nhờ chỉ giáo cách tạo hiệu ứng khi trả về kết quả

lehoanghoc91

Thành viên mới

File đính kèm

SA_DQ

/(hông là gì!

lehoanghoc91

Thành viên mới

Nguyễn Hồng Quang

Thành viên GPE Hà Nội

SA_DQ

/(hông là gì!

VetMini

Ăn cùng góc phố

be_09

Biên Hòa, Đồng Nai

lehoanghoc91

Thành viên mới

batman1

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

be_09

Biên Hòa, Đồng Nai

lehoanghoc91

Thành viên mới

lehoanghoc91

Thành viên mới

SA_DQ

/(hông là gì!

Bài viết mới nhất

Facebook

Group

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