[已解决]如何用VBA实现光标定时/间隔N秒自动下移？

aidfiu

求助各位大大，本人新手
例如光标初始位置A1，5秒后自动下移到B1，再过5秒后自动下移到C1，如此类推
能否实现窗体按钮启动 和 自主选择下移的间隔时间？
找了很久都搞不懂，望各位相助

最佳答案

月排行榜 / 总排行榜

hwc2ycy

2013-11-23 16:16

1. Option Explicit
   
2. Dim dTime As Double
   
3. Dim lRow As Long
   
4. Dim dStep
   
5. Sub 按钮1_Click()
   
6.     dStep = InputBox("输入延迟的秒数[两位数字表示:例如1秒，输入01", Default:=5)
   
7.     If (Not VBA.IsNumeric(dStep)) Or Len(dStep) <> 2 Then
   
8.         MsgBox "录入的非数值或非两位数"
   
9.         exit sub
   
10.     End If
    
11.     Call selectCell
    
12. End Sub
    
13. Sub 按钮2_Click()
    
14.     Application.OnTime dTime, "selectcell", , False
    
15. End Sub
    
16. 
    
17. Sub selectCell()
    
18.     If lRow = Rows.Count Then lRow = 0
    
19.     Cells(lRow + 1, 1).Activate
    
20.     dTime = Now + TimeValue("00:00:" & dStep)
    
21.     Application.OnTime dTime, "selectcell"
    
22.     lRow = lRow + 1
    
23. End Sub

复制代码

跳转到最佳答案楼层

hwc2ycy

1. Option Explicit
   
2. Dim dTime As Double
   
3. Dim lRow As Long
   
4. Dim dStep
   
5. Sub 按钮1_Click()
   
6.     dStep = InputBox("输入延迟的秒数[两位数字表示:例如1秒，输入01", Default:=5)
   
7.     If (Not VBA.IsNumeric(dStep)) Or Len(dStep) <> 2 Then
   
8.         MsgBox "录入的非数值或非两位数"
   
9.         exit sub
   
10.     End If
    
11.     Call selectCell
    
12. End Sub
    
13. Sub 按钮2_Click()
    
14.     Application.OnTime dTime, "selectcell", , False
    
15. End Sub
    
16. 
    
17. Sub selectCell()
    
18.     If lRow = Rows.Count Then lRow = 0
    
19.     Cells(lRow + 1, 1).Activate
    
20.     dTime = Now + TimeValue("00:00:" & dStep)
    
21.     Application.OnTime dTime, "selectcell"
    
22.     lRow = lRow + 1
    
23. End Sub

复制代码

hwc2ycy

按钮1_Click，启动光标下移
按钮2_click,结束光标下移

hwc2ycy

1. Dim dTime As Double
   
2. Dim lRow As Long
   
3. Dim dStep
   
4. 
   
5. Sub StartMoveDown()
   
6.     dStep = InputBox("输入延迟的秒数" & vbNewLine & "[两位数字表示:例如1秒，输入01", Default:=5)
   
7.     If (Not VBA.IsNumeric(dStep)) Or Len(dStep) <> 2 Then
   
8.         MsgBox "录入的非数值或非两位数"
   
9.         Exit Sub
   
10.     End If
    
11.     Call selectCell
    
12. End Sub
    
13. Sub StopMoveDown()
    
14.    on error resume next
    
15.     Application.OnTime dTime, "selectcell", , False
    
16. End Sub
    
17. 
    
18. Sub selectCell()
    
19.     If lRow = Rows.Count Then lRow = 0
    
20.     Cells(lRow + 1, 1).Activate
    
21.     dTime = Now + TimeValue("00:00:" & dStep)
    
22.     Application.OnTime dTime, "selectcell"
    
23.     lRow = lRow + 1
    
24. End Sub
    

复制代码

hwc2ycy

当时间间隔过小时，有可能会取消失败。
光标自动下移.rar (16.59 KB, 下载次数: 25)

2013-11-23 16:21 上传

点击文件名下载附件

aidfiu

谢谢版主啦

hwc2ycy

刚想起来，代码中没有对数值的大小做判断，失误。

1. Dim dTime As Double
   
2. Dim lRow As Long
   
3. Dim strInput$
   
4. 
   
5. Sub StartMoveDown()
   
6.     Dim strPrompt As String
   
7. 
   
8.     On Error Resume Next
   
9. 
   
10.     If dTime Then Call StopMoveDown
    
11. 
    
12.     strPrompt = "输入延迟的秒数" & vbNewLine
    
13.     strPrompt = strPrompt & "[两位数字表示:例如1秒，输入01" & vbNewLine
    
14.     strPrompt = strPrompt & "数值范围在01-59之间"
    
15.     strInput = InputBox(strPrompt, Default:="05")
    
16.    
    
17.     If Len(strInput) <> 2 Or (Not VBA.IsNumeric(strInput)) Then
    
18.         MsgBox "录入的非数值或非两位数字"
    
19.         Exit Sub
    
20.     End If
    
21.    
    
22.     If strInput < 1 Or strInput > 59 Then
    
23.         MsgBox "输入的数值不在01-59区间内"
    
24.         Exit Sub
    
25.     End If
    
26.     lRow = 0
    
27.     Call selectCell
    
28. End Sub
    
29. 
    
30. Sub StopMoveDown()
    
31.     On Error Resume Next
    
32.     Application.OnTime dTime, "selectcell", , False
    
33. End Sub
    
34. 
    
35. Sub selectCell()
    
36.     If lRow = Rows.Count Then lRow = 0
    
37.     Cells(lRow + 1, 1).Activate
    
38.     dTime = Now + TimeValue("00:00:" & strInput)
    
39.     Application.OnTime dTime, "selectcell"
    
40.     lRow = lRow + 1
    
41. End Sub

复制代码