VBA 实现自动滚屏（有表单、使用listbox及wait和ontime的几个效果）

下面部门有个自动滚屏的需求：
一、刚开始的时候并没有表达清楚，只说有滚屏的需求，于是就先做了一个

Sub CommandButton1_Click()
Dim currentrow As Integer
Dim rowscount As Integer

rowscount = ActiveSheet.UsedRange.Rows.Count '获取总行数
goon:

    currentrow = 3 '有标题滚动起始行设为第3行
    Do
    ActiveWindow.scrollrow = currentrow '跳转当前行
    Application.Wait (Now + TimeValue("00:00:01")) '延迟1秒执行下面语句
    ''Now + TimeSerial(0, 0, 1)''这样也行
    currentrow = currentrow + 1 
    Loop Until currentrow = rowscount 
    
GoTo goon  '重复执行，实现从头开始

End Sub

按ESC键可停止执行。
效果如下

VBA 使用wait滚屏1

二、部门的人说不是这样，是想将滚屏做到LISTBOX中，于是将代码改成如下：

Private Sub CommandButton1_Click()
 Dim RNG As Range
    Dim rowscount As Long
    Dim H As Integer, showrows As Integer
    
Application.ScreenUpdating = False
rowscount = UsedRange.Rows.Count
 Set RNG = Range(Cells(2, 1), Cells(rowscount, 3))
'
  ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
ReDim arr(1 To rowscount, 1 To 3)
arr = RNG

 
With ListBox1 '数据列表
again:
    .ListFillRange = "" '清空数据列表
    .ColumnCount = 3   '列表设定3列
    .ColumnWidths = "60;100;150" '每列宽度
    .ColumnHeads = True '默认有标题,标题数据取自源数据第一行的上一行
    .ListFillRange = RNG.Address(, , , True) '获取数据


    H = .Height '数据列表高度
    showrows = Int(H / 12) '大致估算每一页看到的行数，12为每一行的高度
    For i = 1 To rowscount - showrows - 1 '从第1行到显示最后一页的前一行
    .TopIndex = i  '首行显示的数据
    Application.Wait (Now + TimeValue("00:00:01")) '等待一秒
    Next i
GoTo again: '重复执行
End With
Application.DisplayAlerts = True
End Sub

也是按ESC退出，效果如下：

VBA 使用wait滚屏2

三、下面的人说能不能在滚屏的同时还能操作表单，这个有点难度了，经过去查询资料，上EXCELHOME咨询，参考别人的代码，设计如下：
在表单中分别增加表单控件“开始”和“结束”，增加一个模块，在模块中增加代码如下

Option Explicit
   Public rowscount As Long
   Public showrows As Integer
   Public r As Integer
  
  Sub run()
  r = 0 '初始化首行
   Call CommandButton1_Click
  End Sub
''''''''''''''''''''''''''''''''''  
  Sub closed()
   Call ListBox1_Click
  End Sub
 
'''''''''''''''''''''''''''''''''
 Private Sub CommandButton1_Click()
 Dim RNG As Range
 Dim H As Integer

Application.ScreenUpdating = False
rowscount = ActiveSheet.UsedRange.Rows.Count
 Set RNG = Range(Cells(2, 1), Cells(rowscount, 3))
'
   
  ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
ReDim arr(1 To rowscount, 1 To 3)
arr = RNG
  
With ActiveSheet.ListBox1 '数据列表
    .ListFillRange = "" '清空数据列表
    .ColumnCount = 3   '列表设定3列
    .ColumnWidths = "60;100;150" '每列宽度
    .ColumnHeads = True '默认有标题,标题数据取自源数据第一行的上一行
    .ListFillRange = RNG.Address(, , , True) '获取数据
    .TopIndex = .ListCount '首行显示的数据
    
     H = .Height '数据列表高度
     showrows = Int(H / 12) '大致估算每一页看到的行数，12为每一行的高度
End With

ss.delay
Application.DisplayAlerts = True
End Sub


Private Sub ListBox1_Click()
On Error Resume Next
Application.OnTime (Now + TimeValue("00:00:01")), "ss.delay", , False
End Sub

Sub delay()

With ActiveSheet.ListBox1
'首行显示当前行，每过1秒加1，当当前行等于最后一页的首行时，当前行为0
.TopIndex = r
r = r + 1
   If r = rowscount - showrows Then
   r = 0
   End If
    
End With

Application.OnTime (Now + TimeValue("00:00:01")), "ss.delay"
End Sub

“开始"和“结束”分别指定宏“run”和"close”，这次就不需要按ESC了，按“结束”，滚屏中止，效果如下：

VBA 使用listbox+ontime+表单控件+宏 滚屏

四、最后使用ACTIVEX控件来实现，将代码直接写在表单对象中。

Option Explicit
   Public rowscount As Long
   Public showrows As Integer
   Public r As Integer


 Private Sub CommandButton1_Click()

 Dim RNG As Range
 Dim H As Integer

Application.ScreenUpdating = False
rowscount = ActiveSheet.UsedRange.Rows.Count
 Set RNG = Range(Cells(2, 1), Cells(rowscount, 3))
'
   
  ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
ReDim arr(1 To rowscount, 1 To 3)
arr = RNG
  
With ActiveSheet.ListBox1 '数据列表

    .ListFillRange = "" '清空数据列表
    .ColumnCount = 3   '列表设定3列
    .ColumnWidths = "60;100;150" '每列宽度
    .ColumnHeads = True '默认有标题,标题数据取自源数据第一行的上一行
    .ListFillRange = RNG.Address(, , , True) '获取数据
    .TopIndex = .ListCount '首行显示的数据
    
     H = .Height '数据列表高度
     showrows = Int(H / 12) '大致估算每一页看到的行数，12为每一行的高度
End With

delay
Application.DisplayAlerts = True
End Sub


Private Sub CommandButton2_Click()
On Error Resume Next
Application.OnTime (Now + TimeValue("00:00:01")), "sheet4.delay", , False
End Sub

Sub delay()
With ActiveSheet.ListBox1
'首行显示当前行，每过1秒加1，当当前行等于最后一页的首行时，当前行为0
.TopIndex = r
r = r + 1

   If r = rowscount - showrows Then
   r = 0
   End If
    
End With

Application.OnTime (Now + TimeValue("00:00:01")), "sheet4.delay"
End Sub

效果如下：

listbox+ontime+ActiveX控件滚屏

当在左侧数据区域增加或减少数据后，再次点击开始，就会更新数据，反正这样基本能够满足部门需求，soso

另外有大神给了一段代码，也能实行滚屏的效果，可以借鉴下

Sub test()
Set ws = Worksheets("数据")
h = ws.Range("A65536").End(xlUp).Row
With ListBox1
.Clear
.ColumnCount = 3
.ColumnWidths = "60;90;100"
.List = ws.Range("a2:c" & h).Value
End With
For i = 1 To ListBox1.ListCount
yc (0.5)
ListBox1.TopIndex = i
Next
End Sub

Sub yc(t As Single)
Dim time1 As Single
time1 = Timer
Do
    DoEvents
Loop While Timer - time1 < t
End Sub