Board logo

標題: [發問] Excel 播放四個分頁 [打印本頁]
作者: fantersy    時間: 2016-6-13 17:06     標題: Excel 播放四個分頁

各位先進好

有一問題想請教
小弟有四個分頁都在同一個檔案
想使用巨集讓四個分頁都能分別出現
就像PPT檔一樣輪播

小弟用了
Application.Wait waitTime
做延遲5秒後再其它分頁
但會卡住....
用了
Application.OnTime Now + TimeValue("00:00:05"), "我的分頁"
一樣會卡住
請問有別的語法或者小弟那邊寫錯了嗎?
作者: fantersy    時間: 2016-6-13 17:37

回復 1# fantersy


    各位先進好!!
小弟用下列語法寫出...
是可以執行....
請問有更好的寫法嗎??
另外可以設定熱鍵開始跟關閉嗎?

Sub 輪播()
For X = 1 To 5

newHour = Hour(Now())
newMinute = Minute(Now())
newSecond = Second(Now()) + 5 + X
newSecond1 = Second(Now()) + 10 + X
newSecond2 = Second(Now()) + 15 + X
newSecond3 = Second(Now()) + 20 + X
waitTime = TimeSerial(newHour, newMinute, newSecond)
waitTime1 = TimeSerial(newHour, newMinute, newSecond1)
waitTime2 = TimeSerial(newHour, newMinute, newSecond2)
waitTime3 = TimeSerial(newHour, newMinute, newSecond3)

Sheets("生產日報表-焊錫線").Select
ActiveWindow.ScrollColumn = 1
Application.Wait waitTime

Sheets("生產日報表-組立一線").Select
ActiveWindow.ScrollColumn = 1

Application.Wait waitTime1

Sheets("生產日報表-組立二線").Select
ActiveWindow.ScrollColumn = 1

Application.Wait waitTime2

Sheets("生產日報表-測試線").Select
ActiveWindow.ScrollColumn = 1
Application.Wait waitTime3

Next


End Sub
作者: stillfish00    時間: 2016-6-14 09:56

回復 2# fantersy
以下放在ThisWorkbook , 開檔案時定義好熱鍵
  1. Private Sub Workbook_Open()
  2.     Application.OnKey "^+a", "AutoPlay"     'Ctrl + Shift + a  開始
  3.     Application.OnKey "^+s", "StopPlay"     'Ctrl + Shift + s  停止
  4. End Sub
複製代碼
以下放在一般模組
  1. Private inPlay As Boolean
  2. Private nextTime As Date
  3. Private index As Long
  4. Sub AutoPlay()
  5.     StopPlay    'stop previous schedule
  6.    
  7.     inPlay = True
  8.     index = 1
  9.     LoopDisplaySheet
  10. End Sub
  11. Sub StopPlay()
  12.     If inPlay Then
  13.         Application.OnTime nextTime, "LoopDisplaySheet", , False    '取消已存在排程
  14.         inPlay = False
  15.     End If
  16. End Sub
  17. Sub LoopDisplaySheet()
  18.     Application.Goto Sheets(index).Range("A1"), True
  19.    
  20.     If index = Sheets.Count Then
  21.         Exit Sub
  22.     Else
  23.         nextTime = Now + TimeValue("00:00:01")
  24.         index = index + 1
  25.         Application.OnTime nextTime, "LoopDisplaySheet"
  26.     End If
  27. End Sub
複製代碼
作者: fantersy    時間: 2016-6-14 13:31

回復 3# stillfish00

好厲害的寫法!!
謝謝大大的幫忙~真的受教了
學到不少~感恩!!
作者: fantersy    時間: 2016-6-14 13:53

回復 3# stillfish00


    stillfish00 大大你好!!
小弟剛測試了一下!!
1.所有分頁都能輪放一次, 請問能指定某些分頁嗎?
2.輪放一次後即停止，請問能一直輪放到下熱鍵停止後才停的動作嗎?

抱歉!!麻煩大大解惑
作者: stillfish00    時間: 2016-6-14 17:20

回復 5# fantersy
  1. Private nextTime As Date
  2. Private index As Long
  3. Sub AutoPlay()
  4.     StopPlay    'stop previous schedule
  5.    
  6.     index = 0
  7.     LoopDisplaySheet
  8. End Sub
  9. Sub StopPlay()
  10.     On Error Resume Next
  11.     Application.OnTime nextTime, "LoopDisplaySheet", , False    '取消已存在排程
  12. End Sub
  13. Sub LoopDisplaySheet()
  14.     Dim arSheets
  15.     arSheets = Array("工作表1", "工作表2", "工作表3")
  16.    
  17.     Application.Goto Sheets(arSheets(index)).Range("A1"), True
  18.    
  19.     If index = UBound(arSheets) Then
  20.         index = 0
  21.     Else
  22.         index = index + 1
  23.     End If
  24.         
  25.     nextTime = Now + TimeValue("00:00:01")
  26.     Application.OnTime nextTime, "LoopDisplaySheet"
  27. End Sub
複製代碼
作者: fantersy    時間: 2016-6-16 20:46

回復  fantersy
stillfish00 發表於 2016-6-14 17:20


謝謝大大的幫忙

真的很受用!!感恩!!



歡迎光臨 麻辣家族討論版版 (http://forum.twbts.com/)