返回列表 上一主題 發帖

[發問] 可否幫忙改善迴圈速度

s13030029
　暱稱: 伊恩

中學生Rank: 2

帖子
97 
主題
33 
精華
0 
積分
129 
點名
0  
作業系統
Win 7 
軟體版本
office 2007 
閱讀權限
20 
性別
男 
註冊時間
2019-5-7 
最後登錄
2022-8-25 
1# 跳轉到 » 倒序看帖
打印
tT
發表於 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
複製代碼
test2.rar (40.14 KB)
收藏 分享

s13030029
　暱稱: 伊恩

中學生Rank: 2

帖子
97 
主題
33 
精華
0 
積分
129 
點名
0  
作業系統
Win 7 
軟體版本
office 2007 
閱讀權限
20 
性別
男 
註冊時間
2019-5-7 
最後登錄
2022-8-25 
2#
發表於 2019-6-12 08:19 | 顯示全部帖子
回復 2# n7822123
我的表格會依檢驗項目如果超過21項，也就是第一張表填滿了，就會自動增加第二張表格在下面，繼續把資料填上，所以現在47列開始才會是空的

附檔： test2.rar (56.35 KB)

TOP

s13030029
　暱稱: 伊恩

中學生Rank: 2

帖子
97 
主題
33 
精華
0 
積分
129 
點名
0  
作業系統
Win 7 
軟體版本
office 2007 
閱讀權限
20 
性別
男 
註冊時間
2019-5-7 
最後登錄
2022-8-25 
3#
發表於 2019-6-12 08:21 | 顯示全部帖子
其實不應該用xlDown對不對?

TOP

s13030029
　暱稱: 伊恩

中學生Rank: 2

帖子
97 
主題
33 
精華
0 
積分
129 
點名
0  
作業系統
Win 7 
軟體版本
office 2007 
閱讀權限
20 
性別
男 
註冊時間
2019-5-7 
最後登錄
2022-8-25 
4#
發表於 2019-6-12 10:45 | 顯示全部帖子
回復 7# n7822123
原來如此~~~非常感謝~~~

TOP

        靜思自在 : 真正的愛心，是照顧好自己的這顆心。
返回列表 上一主題