Board logo

標題: [發問] 可否幫忙改善迴圈速度 [打印本頁]
作者: s13030029    時間: 2019-6-11 11:31     標題: 可否幫忙改善迴圈速度

程式碼下，檔案中請點擊"另存i-Link路徑檔"執行巨集，謝謝幫忙~
  1. Sub 匯出製程至路徑檔()

  3.     Application.ScreenUpdating = False
  4.     Application.DisplayAlerts = False
  5.     If Cells(11, "A") Like "外觀" Then       '外觀
  6.                 Cells(11, "F").Value = "D,1,1"
  7.                 Cells(11, "G").Value = "D,1,2"
  8.                 Cells(11, "H").Value = "D,1,3"
  9.                 Cells(11, "I").Value = "D,1,4"
  10.                 Cells(11, "J").Value = "D,1,5"
  11.     End If
  12.    
  13.     lastRow = Sheets("製程檢查記錄表").Columns(2).Find(What:="", LookIn:=xlValues, _
  14.     SearchDirection:=xlNext, AFTER:=Range("B12")).Row
  15.    
  16.     For I = 12 To lastRow              'Range("A12").End(xlDown).Row
  17.             If Cells(I, "B") <> "" Then
  18.                 Cells(I, "F").Value = "D," & Cells(I, "A").Value + 1 & ",1"
  19.                 Cells(I, "G").Value = "D," & Cells(I, "A").Value + 1 & ",2"
  20.                 Cells(I, "H").Value = "D," & Cells(I, "A").Value + 1 & ",3"
  21.                 Cells(I, "I").Value = "D," & Cells(I, "A").Value + 1 & ",4"
  22.                 Cells(I, "J").Value = "D," & Cells(I, "A").Value + 1 & ",5"
  23.             Else
  24.             End If
  25.     Next
  26.    
  27.     For I = 47 To Range("A47").End(xlDown).Row
  28.         If Cells(I, "B") <> "" Then
  29.             If Cells(I, "B") <> "" Then
  30.                 Cells(I, "F").Value = "D," & Cells(I, "A").Value + 1 & ",1"
  31.                 Cells(I, "G").Value = "D," & Cells(I, "A").Value + 1 & ",2"
  32.                 Cells(I, "H").Value = "D," & Cells(I, "A").Value + 1 & ",3"
  33.                 Cells(I, "I").Value = "D," & Cells(I, "A").Value + 1 & ",4"
  34.                 Cells(I, "J").Value = "D," & Cells(I, "A").Value + 1 & ",5"
  35.             Else
  36.             End If
  37.         End If
  38.     Next
  39.    
  40.     Application.ScreenUpdating = True
  41.     Application.DisplayAlerts = True
  42.     Range("A11").Select
  43.    
  44.     Dim xlFolder As String
  45.     xlFolder = ThisWorkbook.Path & "\" & "i-Link 路徑檔"        '指定資料夾
  46.     If Dir(xlFolder, vbDirectory) = "" Then MkDir xlFolder

  48.     Dim xPath As String
  49.     xPath = Application.ActiveWorkbook.Path
  50.     Application.ScreenUpdating = False
  51.     Application.DisplayAlerts = False
  52.     Titlename = ThisWorkbook.Sheets("製程檢查記錄表").Range("H4").Value
  53.     With ActiveSheet
  54.        .Copy
  55.        ActiveSheet.DrawingObjects.Delete
  56.        X = InputBox("請輸入檔名!!", "另存新檔", Titlename & " " & "製程(路徑檔)")
  57.         If X <> "" Then
  58.             Application.ActiveWorkbook.SaveAs Filename:=xlFolder & "\" & X, _
  59.             FileFormat:=xlExcel8
  60.             MsgBox "儲存成功！"
  61.         ElseIf X = "" Then
  62.             MsgBox "已取消儲存!!!"
  63.         End If
  64.        Application.ErrorCheckingOptions.BackgroundChecking = False
  65.        Application.ActiveWorkbook.Close False
  66.     End With
  67.    
  68.     For I = 11 To Range("B11").End(xlDown).Row
  69.         If Cells(I, "A") <> "" Then
  70.             Cells(I, "F").Value = ""
  71.             Cells(I, "G").Value = ""
  72.             Cells(I, "H").Value = ""
  73.             Cells(I, "I").Value = ""
  74.             Cells(I, "J").Value = ""
  75.         ElseIf Cells(I, "A") = "" Then
  76.             Exit For
  77.         End If
  78.     Next
  79.     For I = 47 To Range("A47").End(xlDown).Row
  80.         If Cells(I, "A") <> "" Then
  81.             Cells(I, "F").Value = ""
  82.             Cells(I, "J").Value = ""
  83.             Cells(I, "H").Value = ""
  84.             Cells(I, "I").Value = ""
  85.             Cells(I, "J").Value = ""
  86.         ElseIf Cells(I, "A") = "" Then
  87.             Exit For
  88.         End If
  89.     Next
  90.    
  91.     Application.DisplayAlerts = True
  92.     Application.ScreenUpdating = True
  93.    
  94.    
  95. End Sub
複製代碼
[attach]30838[/attach]
作者: n7822123    時間: 2019-6-11 23:54

本帖最後由 n7822123 於 2019-6-11 23:56 編輯

回復 1# s13030029

這段程式!? 判斷重複....且跑了100多萬列...........

    For I = 47 To Range("A47").End(xlDown).Row
        If Cells(I, "B") <> "" Then
            If Cells(I, "B") <> "" Then
                Cells(I, "F").Value = "D," & Cells(I, "A").Value + 1 & ",1"
                Cells(I, "G").Value = "D," & Cells(I, "A").Value + 1 & ",2"
                Cells(I, "H").Value = "D," & Cells(I, "A").Value + 1 & ",3"
                Cells(I, "I").Value = "D," & Cells(I, "A").Value + 1 & ",4"
                Cells(I, "J").Value = "D," & Cells(I, "A").Value + 1 & ",5"
            Else
            End If
        End If
    Next

時間主要卡在你程式碼27~38列的部分，

因為你給的檔案從A47以後都沒資料，所以不知道這段程式到底要幹嘛!

迴圈會重47列跑到1048576........且儲存格都是空白，等於白跑了100多萬列!

如果你把這段註解掉，會發現速度馬上提昇。
作者: s13030029    時間: 2019-6-12 08:19

回復 2# n7822123
我的表格會依檢驗項目如果超過21項，也就是第一張表填滿了，就會自動增加第二張表格在下面，繼續把資料填上，所以現在47列開始才會是空的

附檔：[attach]30843[/attach]
作者: s13030029    時間: 2019-6-12 08:21

其實不應該用xlDown對不對?
作者: n7822123    時間: 2019-6-12 08:56

本帖最後由 n7822123 於 2019-6-12 09:00 編輯

回復 4# s13030029


恩恩，應該每張表格都給他一個範圍去跑就好了

舉例來說你第2張表格會從A47 到A67，就把你的I固定從 47到67就可以了

如果會有第3張表格與第4張表格也類似處理，不太可能跑到1048576列的....
作者: n7822123    時間: 2019-6-12 09:15

本帖最後由 n7822123 於 2019-6-12 09:19 編輯

回復 5# n7822123


可根據一些表格固定會出現字眼，先判斷會有幾個表格，再設立範圍

舉例 :
每張表格固定跑20列(第一張從12跑到31)，有30張表格(變數T)，
假設每張表格的儲存格位置相差37列，可以改成如下

For T=1 to 30  '假設有30張表格
    For I = T*37-25 To T*37-6  '第一列與最後一列依據第T張表格做變動
            If Cells(I, "B") <> "" Then
                Cells(I, "F").Value = "D," & Cells(I, "A").Value + 1 & ",1"
                Cells(I, "G").Value = "D," & Cells(I, "A").Value + 1 & ",2"
                Cells(I, "H").Value = "D," & Cells(I, "A").Value + 1 & ",3"
                Cells(I, "I").Value = "D," & Cells(I, "A").Value + 1 & ",4"
                Cells(I, "J").Value = "D," & Cells(I, "A").Value + 1 & ",5"
            Else
            End If
    Next I
Next T

當然這還是可以優化的，用陣列處理可以更快。
作者: n7822123    時間: 2019-6-12 09:33

回復 6# n7822123


End(xlDown) 可適用於 確定有資料 的情況下，無資料會跑到最末列

使用前要先判斷是否有資料
作者: s13030029    時間: 2019-6-12 10:45

回復 7# n7822123
原來如此~~~非常感謝~~~



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