彰化一整天的論壇

 找回密碼
 立即註冊
查看: 345|回復: 6

VBA執行會lag

[複製鏈接]
發表於 2017-8-21 18:21:33 | 顯示全部樓層 |閱讀模式
本帖最後由 yloe 於 2017-8-21 18:48 編輯

各位先進
我從網路上抓了一個抽獎的vba,然後修改了一下(如附件)目前抽獎名單是暫時用數字來代替,未來會是人名,數量可能達到3萬個
在執行vba時,有以下疑問,是否能提供小弟一些指引,謝謝
1.每按"開始抽獎",電腦都會停頓了30秒左右,這是電腦不夠力嗎,有改善的方式嗎2.假如沒辦法改善的話,能在讀取前讓他跑一個loading的畫面,來掩蓋電腦lag的畫面嗎
3.在工作表"抽獎"中,抽獎結果顯示是一整排列出,有辦法調整成每10個一排嗎
4.檔案中可以好像有欄位被隱藏,有取消保護,但可編輯的範圍還是有被限制住,這是要怎麼做到

ps.針對執行vba會停頓,有試過把獎項數量都降低在5個以下,但依舊沒改善

百萬抽獎.xlsm

356.08 KB, 下載次數: 64

回復

使用道具 舉報

發表於 2017-8-21 22:23:58 | 顯示全部樓層
您好,
    我有幫您修改部分.目前執行起來應該是還OK.
  1. Private Sub SetLevelString()
  2.    Dim strL4 As String
  3.    Dim strLevel As String
  4.    
  5.   
  6.    
  7.    Select Case iCurrentLevel
  8.      Case 1:
  9.         strLevel = "頭獎"
  10.      Case 2:
  11.         strLevel = "貳獎"
  12.      Case 3:
  13.         strLevel = "參獎"
  14.      Case 4:
  15.         strLevel = "肆獎"
  16.      Case 5:
  17.         strLevel = "伍獎"
  18.      Case 6:
  19.         strLevel = "陸獎"
  20.      Case 7:
  21.         strLevel = "柒獎"
  22.      Case 8:
  23.         strLevel = "捌獎"
  24.      Case 9:
  25.         strLevel = "備取"
  26.    End Select
  27.    
  28.    Sheets("抽獎").Range("A4").Value = strLevel
  29. End Sub

  30. Private Function GetLevelResultColumn() As String
  31.   
  32.    Select Case iCurrentLevel '設定"抽獎結果"-欄位位置
  33.      Case 1:
  34.         GetLevelResultColumn = "A" '"抽獎結果"A欄(頭獎)
  35.      Case 2:
  36.         GetLevelResultColumn = "B" '"抽獎結果"B欄(貳獎)
  37.      Case 3:
  38.         GetLevelResultColumn = "C"
  39.      Case 4:
  40.         GetLevelResultColumn = "D"
  41.      Case 5:
  42.         GetLevelResultColumn = "E"
  43.      Case 6:
  44.         GetLevelResultColumn = "F"
  45.      Case 7:
  46.         GetLevelResultColumn = "G"
  47.      Case 8:
  48.         GetLevelResultColumn = "H"
  49.      Case 9:
  50.         GetLevelResultColumn = "I"
  51.    End Select
  52. End Function



  53. Private Sub PrintResultButton_Click() '設定"抽獎"列印抽獎結果按鍵
  54.     If (iCurrentStatus = 1 Or iCurrentStatus = 2) Then
  55.         Exit Sub
  56.     End If
  57.     Sheets("抽獎結果").PrintOut
  58.    
  59.    
  60. End Sub

  61. Private Function fDuplicatedCandidate(ByVal iCandidate As Integer) As Boolean
  62.     Dim i As Integer
  63.    
  64.     fDuplicatedCandidate = False '?
  65.     For i = 1 To UBound(arrCandidatesSelected)
  66.         If iCandidate = arrCandidatesSelected(i) Then
  67.             fDuplicatedCandidate = True
  68.         End If
  69.     Next i
  70.    
  71. End Function


  72. Private Sub LuckyDraw()
  73.     Dim i As Integer
  74.     Dim strL4 As String
  75.     Dim strL4New As String
  76.     Dim strCandidateIndex As String
  77.     Dim strShowListIndex As String
  78.    
  79.     While (iCurrentStatus = 1) '當抽獎開始
  80.         
  81.         If (iCountPerSelect = 0) Then '當一次抽獎的數量=0
  82.             iCurrentLevel = iCurrentLevel + iStep '?由小獎抽到大獎 9-1
  83.             If (iCurrentLevel = iLastLevel) Then '當抽獎程序到抽大獎時
  84.                 Exit Sub
  85.             End If
  86.         
  87.             If iSelectMethod = 1 Then '一次抽一整組
  88.                 iCountPerSelect = GetLevelAwardAmount() '一次抽完抽獎名額的量
  89.             Else
  90.                 If (GetLevelAwardAmount() < iPerSelectSetting) Then
  91.                     iCountPerSelect = GetLevelAwardAmount() '假如獎項數量<設定數量,那就以獎項數量為準
  92.                 Else
  93.                     iCountPerSelect = iPerSelectSetting
  94.                 End If
  95.                
  96.             End If
  97.         End If
  98.         
  99.         SetLevelString
  100.                
  101.         For i = 1 To iCountPerSelect
  102.             'Expect 2-
  103.             iCurrentCandidate = Int((iTotalCandidates) * Rnd + 2) '2~抽獎名單總數中取亂數
  104.             While fDuplicatedCandidate(iCurrentCandidate)
  105.                 iCurrentCandidate = Int((iTotalCandidates) * Rnd + 2)
  106.             Wend
  107.             arrCandidatesSelected(iTotalSelected + i) = iCurrentCandidate '?
  108.             
  109.             strCandidateIndex = "A" + Format(iCurrentCandidate) '"抽獎名單"-亂數位置
  110.             'strShowListIndex = "L" + Format(i + 4 + iLevelSelected)
  111.             strShowListIndex = "a" + Format(i + 4) '亂數抽獎結果顯示位置
  112.             Sheets("抽獎").Range(strShowListIndex).Value = Sheets("抽獎名單").Range(strCandidateIndex).Value '亂數抽獎結果顯示在"抽獎名單"的指定位置
  113.             
  114.             If (iTotalSelected + i = iTotalCandidates) Then '?
  115.                 Sheets("抽獎").StartEndButton.Value = False
  116.                 Exit Sub
  117.             End If
  118.         Next i
  119.          
  120.         DoEvents
  121.          
  122.     Wend
  123.    
  124.    
  125.    
  126.    
  127.    
  128. End Sub


  129. Private Sub StartEndButton_Click()
  130.     Dim i As Long
  131.     Dim strShowListIndex As String
  132.     Dim strResultListIndex As String
  133.    
  134.     If iCurrentStatus = 0 Then '準備開始抽獎
  135.          If (Sheets("抽獎").StartEndButton.Value = False) Then
  136.             Exit Sub
  137.          End If
  138.          Application.Run "start_run"
  139.          
  140.         'Just start to draw
  141.         If ActiveWorkbook.Sheets("抽獎名單").UsedRange.Rows.Count <= 1 Then
  142.             MsgBox "請先輸入抽獎名單。", vbOKOnly, STR_TITLE
  143.             Sheets("抽獎").StartEndButton.Value = False
  144.             Exit Sub
  145.         Else '>1
  146.             'iTotalCandidates = ActiveWorkbook.Sheets("抽獎名單").UsedRange.Rows.Count - 1
  147.             iTotalCandidates = ActiveWorkbook.Sheets("抽獎名單").Range("A1").End(xlDown).Row    '改成這樣以實際人數為主
  148.             Do While (iTotalCandidates > 0)
  149.                 'Remove the ending empty lines
  150.                 If IsEmpty(ActiveWorkbook.Sheets("抽獎名單").UsedRange.Rows(iTotalCandidates + 1)) Then
  151.                     iTotalCandidates = iTotalCandidates - 1
  152.                 Else
  153.                     Exit Do
  154.                 End If
  155.                 DoEvents    '不要讓它看起來像當機
  156.             Loop
  157.             For i = iTotalCandidates To 1 Step -1
  158.                 If IsEmpty(ActiveWorkbook.Sheets("抽獎名單").UsedRange.Rows(i)) Then
  159.                     MsgBox "請先移除抽獎名單中的空行。", vbOKOnly, STR_TITLE
  160.                     Sheets("抽獎").StartEndButton.Value = False
  161.                     Exit Sub
  162.                 End If
  163.             Next i
  164.         End If
  165.         
  166.                
  167.         iTotalAwardCount = Sheets("設置").Range("D15")
  168.         'iTotalCount must smaller than iTotalCandidates. = will make the exclusive random function fail
  169.         
  170.         If (iTotalAwardCount <= 0) Then
  171.             MsgBox "請先設置獎項。", vbOKOnly, STR_TITLE
  172.             Sheets("抽獎").StartEndButton.Value = False
  173.             Exit Sub
  174.         ElseIf (iTotalAwardCount > iTotalCandidates) Then
  175.             MsgBox "獎項設置總數不能多於抽獎名單總數", vbOKOnly, STR_TITLE
  176.             Sheets("抽獎").StartEndButton.Value = False
  177.             Exit Sub
  178.         End If
  179.               
  180.         ReDim arrCandidatesSelected(iTotalAwardCount)
  181.         FillLevelAwardAmount
  182.         
  183.         iSelectOrder = Sheets("設置").Range("F6") '先抽小獎=1;先抽大獎=2
  184.         If iSelectOrder = 1 Then '先抽小獎
  185.            iCurrentLevel = 9
  186.            iStep = -1
  187.            iLastLevel = 0
  188.         Else
  189.            iCurrentLevel = 1 '先抽大獎
  190.            iLastLevel = 10
  191.            iStep = 1
  192.         End If

  193.          
  194.         iSelectMethod = Sheets("設置").Range("I6") '一次抽一整組=1;一次抽定額數量=2
  195.         
  196.         If iSelectMethod = 1 Then
  197.             iCountPerSelect = GetLevelAwardAmount()
  198.         Else
  199.             iPerSelectSetting = Sheets("設置").Range("L7")
  200.      
  201.             If (GetLevelAwardAmount() < iPerSelectSetting) Then
  202.                 iCountPerSelect = GetLevelAwardAmount()
  203.             Else
  204.                 iCountPerSelect = iPerSelectSetting
  205.             End If
  206.         End If
  207.          
  208.         iCurrentStatus = 1
  209.         Sheets("抽獎").StartEndButton.Caption = "停止"
  210.      
  211.         LuckyDraw
  212.     ElseIf iCurrentStatus = 1 Then
  213.         'The name on the showlist now are the lucky names
  214.         
  215.         For i = 1 To iCountPerSelect
  216.             strShowListIndex = "a" + Format(i + 4)
  217.             'strShowListIndex = "L" + Format(i + 4 + iLevelSelected)
  218.             'Change the color to show the confirmed list
  219.             'With Sheets("抽獎").Range(strShowListIndex).Interior
  220.             '    .ColorIndex = 45
  221.             '    .Pattern = xlSolid
  222.             '    .PatternColorIndex = xlAutomatic
  223.            ' End With
  224.             'Write the list to corresponding columns in "result" sheet
  225.             strResultListIndex = GetLevelResultColumn() + Format(i + 1 + iLevelSelected)
  226.             Sheets("抽獎結果").Range(strResultListIndex).Value = Sheets("抽獎").Range(strShowListIndex).Value

  227.         Next i
  228.            
  229.         iTotalSelected = iTotalSelected + iCountPerSelect
  230.         iLevelSelected = iLevelSelected + iCountPerSelect
  231.         
  232.         If (iLevelSelected = GetLevelAwardAmount()) Then
  233.             iCurrentLevel = iCurrentLevel + iStep
  234.             If (iCurrentLevel <> iLastLevel) Then
  235.                 fClearShowList = True
  236.                 iLevelSelected = 0
  237.                 If iSelectMethod = 1 Then
  238.                     iCountPerSelect = GetLevelAwardAmount()
  239.                 Else
  240.                     If (GetLevelAwardAmount() < iPerSelectSetting) Then
  241.                         iCountPerSelect = GetLevelAwardAmount()
  242.                     Else
  243.                         iCountPerSelect = iPerSelectSetting
  244.                     End If
  245.                 End If
  246.             
  247.             End If
  248.         Else
  249.             'fClearShowList = False
  250.             'Always clear the show list --Bug 135887-4
  251.             fClearShowList = True
  252.             If (GetLevelAwardAmount() - iLevelSelected < iPerSelectSetting) Then
  253.                     iCountPerSelect = GetLevelAwardAmount() - iLevelSelected
  254.                 Else
  255.                     iCountPerSelect = iPerSelectSetting
  256.             End If
  257.         End If
  258.         
  259.         
  260.       
  261.         If iTotalSelected < iTotalAwardCount Then
  262.             iCurrentStatus = 2
  263.             Sheets("抽獎").StartEndButton.Caption = "繼續抽獎"
  264.         Else
  265.             Sheets("抽獎").StartEndButton.Value = False
  266.             iCurrentStatus = 3
  267.             ActiveWorkbook.Sheets("抽獎").StartEndButton.Caption = "抽獎結束"
  268.             Application.Run "stop_run"
  269.         End If
  270.     ElseIf iCurrentStatus = 2 Then
  271.         'continue to draw
  272.         If (fClearShowList = True) Then
  273.             ClearShowList
  274.         End If
  275.         
  276.         iCurrentStatus = 1
  277.         Sheets("抽獎").StartEndButton.Caption = "停止"
  278.         LuckyDraw
  279.     Else
  280.          'iCurrentStatus = 3
  281.          If (Sheets("抽獎").StartEndButton.Value = False) Then
  282.             Exit Sub
  283.          End If
  284.          
  285.         
  286.          If MsgBox("要重新開始抽獎嗎?" + vbCrLf + "如果重新開始,抽獎結果表單的內容將被清除。 ", vbYesNo, STR_TITLE) = vbNo Then
  287.              Sheets("抽獎").StartEndButton.Value = False
  288.             Exit Sub
  289.          End If
  290.             
  291.         'Restart
  292.          Sheets("抽獎").StartEndButton.Value = False
  293.          
  294.          ClearShowList
  295.          ClearResultList
  296.          ResetLevelString
  297.          
  298.          iTotalSelected = 0
  299.          iLevelSelected = 0
  300.          iCurrentStatus = 0
  301.          
  302.          Sheets("抽獎").StartEndButton.Caption = "開始抽獎"
  303.     End If
  304. End Sub
複製代碼


百萬抽獎.xlsm

351.13 KB, 下載次數: 3

售價: 1 金錢  [記錄]

回復 支持 反對

使用道具 舉報

 樓主| 發表於 2017-8-22 12:59:04 | 顯示全部樓層
謝謝,版主的回應
不知道版主是改了哪裡,有對了一下,找不到不一樣的地方
另外有試過把版主提供的檔案貼了2萬筆的資料,就還是會lag
我再試試看把程式碼簡化一下
回復 支持 反對

使用道具 舉報

發表於 2017-8-22 13:19:27 | 顯示全部樓層
yloe 發表於 2017-8-22 12:59
謝謝,版主的回應
不知道版主是改了哪裡,有對了一下,找不到不一樣的地方
另外有試過把版主提供的檔案貼了 ...

我在156行修改
           iTotalCandidates = ActiveWorkbook.Sheets("抽獎名單").Range("A1").End(xlDown).Row    '改成這樣以實際人數為主
及164行加入
                DoEvents    '不要讓它看起來像當機
回復 支持 反對

使用道具 舉報

發表於 2017-8-22 16:52:04 | 顯示全部樓層
tsaimh 發表於 2017-8-22 13:19
我在156行修改
           iTotalCandidates = ActiveWorkbook.Sheets("抽獎名單").Range("A1").End(xlDo ...

可以加入我的那個進度表, 就不會感覺停頓了
回復 支持 反對

使用道具 舉報

 樓主| 發表於 2017-8-31 15:27:22 | 顯示全部樓層
感謝 goodnight的建議
有試著加進度表,但在進度表還沒跑出來前就卡住了
我再試試看
回復 支持 反對

使用道具 舉報

發表於 2017-9-4 17:04:12 | 顯示全部樓層
yloe 發表於 2017-8-31 15:27
感謝 goodnight的建議
有試著加進度表,但在進度表還沒跑出來前就卡住了
我再試試看 ...

vba跑得慢是正常的, 不要太在意, 有時候是寫法的問題, 只能接受這個事實
如果能找出卡住的原因, 才能試著去改善, 但不一定能改善, 因為一個cell一個cell去跑, 本來就一定會很慢,
除非改變架構, 資料量那麼大, 都不知道能不能丟到陣列裡去跑, 這樣可能就會快很多了
回復 支持 反對

使用道具 舉報

您需要登錄後才可以回帖 登錄 | 立即註冊

本版積分規則

 ㄚ母滴雞湯
 員林香純滴雞精

Archiver|手機版|小黑屋|彰化一整天的論壇(Excel,Office)  |网站地图

GMT+8, 2018-10-17 09:55 , Processed in 0.130410 second(s), 22 queries .

Powered by Discuz! X3.2

© 2001-2013 Comsenz Inc.

快速回復 返回頂部 返回列表