返回列表 上一主題 發帖

[發問] 請教：加速方法

198188

帖子
578 
主題
74 
精華
0 
積分
677 
點名
1  
作業系統
win7 
軟體版本
office 2010 
閱讀權限
50 
性別
男 
註冊時間
2012-10-30 
最後登錄
2025-12-24 
1# 跳轉到 » 倒序看帖
打印
tT
發表於 3 天前 17:57 | 只看該作者

[發問] 請教：加速方法

  1. Sub Copy_Rack_Item()

  3. Dim Brr, Arr, i&, n&, Q&, T$, S$, MyPath$, xFile$, xBook As Workbook, Re

  5. Worksheets("Rack").Range("A2:O65600").Delete
  6. Worksheets("Item").Range("A2:O65600").Delete
  7. n = 2
  8. T = Worksheets("Inv").Range("M1")
  9. Application.ScreenUpdating = False

  11. MyPath = "S:\EXPORT SHIPMENT\"
  12. xFile = "Delivery Note Input Template.xlsx"
  13. On Error Resume Next
  14. Set xBook = Workbooks(xFile)
  15. If xBook Is Nothing Then
  16.    Set xBook = Workbooks.Open(MyPath & xFile, , True, , "")
  17.    Re = True: ThisWorkbook.Activate
  18. End If
  19. On Error GoTo 0


  22. Brr = xBook.Sheets("Rack").UsedRange
  23. For i = 2 To UBound(Brr)
  24.    
  25.    If xBook.Sheets("Rack").Cells(i, 11) = T Then
  26.       xBook.Sheets("Rack").Rows(i).Copy Destination:=Worksheets("Rack").Rows(n)
  27.       n = n + 1
  28.    End If
  29. Next i

  31. Q = 2
  32. S = Worksheets("Rack").Range("A2")
  33. Arr = xBook.Sheets("Item").UsedRange
  34. For i = 2 To UBound(Arr)
  35.    If xBook.Sheets("Item").Cells(i, 1) = S Then
  36.       xBook.Sheets("Item").Rows(i).Copy Destination:=Worksheets("Item").Rows(Q)
  37.       Q = Q + 1
  38.    End If
  39. Next i

  41. 12: If Re = True Then xBook.Close 0
  42. End Sub
複製代碼
有兩個Excel,
本檔，Inv 表 M1儲存格 是 Invoice no
本檔，Rack 表 複製目的地 Row 2 開始
本檔，Item 表 複製目的地 Row 2 開始

來源檔 Delivery Note Input Template.xlsx
本檔，Rack 表  K 欄是 Invoice No,  A 欄是 Work Order No
本檔，Item 表 A 欄是 Work Order No

如果來源檔Rack 表 K 欄 的 Invoice No 等於 本檔Inv 表 M1儲存格 是 Invoice no
複製  來源檔 Rack 表該欄到 本檔Rack 表 複製目的地 Row 2 開始往下

如果來源檔 Item 表 A 欄是 Work Order No 等於 本檔Rack 表A 欄是 Work Order No
複製  來源檔  Item 表 該欄到 本檔 Item 表  複製目的地 Row 2 開始往下
收藏 分享

198188

帖子
578 
主題
74 
精華
0 
積分
677 
點名
1  
作業系統
win7 
軟體版本
office 2010 
閱讀權限
50 
性別
男 
註冊時間
2012-10-30 
最後登錄
2025-12-24 
2#
發表於 前天 09:33 | 只看該作者
有兩個Excel,
本檔，Inv 表 M1儲存格 是 Invoice no
本檔，Rack 表 複製目的地 Row 2 開始
本檔，Item  ...
198188 發表於 2025-12-22 17:57



附上範例。

Desktop.rar (40.05 KB)

TOP

198188

帖子
578 
主題
74 
精華
0 
積分
677 
點名
1  
作業系統
win7 
軟體版本
office 2010 
閱讀權限
50 
性別
男 
註冊時間
2012-10-30 
最後登錄
2025-12-24 
3#
發表於 前天 10:32 | 只看該作者
附上範例。
198188 發表於 2025-12-23 09:33


由於來源檔 Rack  & Item 都有過萬行數據，所以采用 For Loop 運行 時間太久，甚至會卡住。
請各位大大幫忙，看有什麽方法可以縮短這個運行時間。

TOP

198188

帖子
578 
主題
74 
精華
0 
積分
677 
點名
1  
作業系統
win7 
軟體版本
office 2010 
閱讀權限
50 
性別
男 
註冊時間
2012-10-30 
最後登錄
2025-12-24 
4#
發表於 前天 14:12 | 只看該作者
  1. Option Explicit

  3. Sub Copy_Rack_Item()

  5. Dim z, Q, i&, n&, T$, T1$, MyPath$, xFile$, xBook As Workbook, Re, m

  7. Worksheets("Rack").Range("A2:O65600").Delete
  8. Worksheets("Item").Range("A2:O65600").Delete


  11. Application.ScreenUpdating = False

  13. MyPath = "S:\EXPORT SHIPMENT\"
  14. xFile = "Delivery Note Input Template.xlsx"
  15. On Error Resume Next
  16. Set xBook = Workbooks(xFile)
  17. If xBook Is Nothing Then
  18.    Set xBook = Workbooks.Open(MyPath & xFile, , True, , "")
  19.    Re = True: ThisWorkbook.Activate
  20. End If
  21. On Error GoTo 0
  22. n = 2
  23. Set z = CreateObject("Scripting.Dictionary")
  24. T = Worksheets("Inv").Range("M1")

  26. With xBook.Sheets("Rack")
  27.    For i = 2 To xBook.Sheets("Rack").Cells(Rows.count, "A").End(xlUp).Row
  28.       If xBook.Sheets("Rack").Cells(i, "K") = T Then
  29.          xBook.Sheets("Rack").Rows(i).Copy Sheets("Rack").Rows(n)
  30.          n = n + 1
  31.       End If
  32.    Next i
  33. End With

  35. T1 = Sheets("Rack").[A2]
  36. m = 2
  37. With xBook.Sheets("Item")
  38.    For i = 2 To xBook.Sheets("Item").Cells(Rows.count, "A").End(xlUp).Row
  39.       If xBook.Sheets("Item").Cells(i, "A") = T1 Then
  40.          xBook.Sheets("Item").Rows(i).Copy Sheets("Item").Rows(m)
  41.          m = m + 1
  42.       End If
  43.    Next i
  44. End With

  46. 12: If Re = True Then xBook.Close 0
  47. End Sub
複製代碼
由於來源檔 Rack  & Item 都有過萬行數據，所以采用 For Loop 運行 時間太久，甚至會卡住。
請各位大大 ...
198188 發表於 2025-12-23 10:32


修改了這個代碼，速度快了一些，不過還是要幾分鐘。不知道這個速度是否最快。
Rack 的數據有2萬行
Item 的數據有20萬行

TOP

        靜思自在 : 信心、毅力、勇氣三者具備，則天下沒有做不成的事。
返回列表 上一主題