Board logo

標題: [發問] 請教:加速方法 [打印本頁]

作者: 198188    時間: 2025-12-22 17:57     標題: 請教:加速方法

  1. Sub Copy_Rack_Item()

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

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

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


  17. Brr = xBook.Sheets("Rack").UsedRange
  18. For i = 2 To UBound(Brr)
  19.    
  20.    If xBook.Sheets("Rack").Cells(i, 11) = T Then
  21.       xBook.Sheets("Rack").Rows(i).Copy Destination:=Worksheets("Rack").Rows(n)
  22.       n = n + 1
  23.    End If
  24. Next i

  25. Q = 2
  26. S = Worksheets("Rack").Range("A2")
  27. Arr = xBook.Sheets("Item").UsedRange
  28. For i = 2 To UBound(Arr)
  29.    If xBook.Sheets("Item").Cells(i, 1) = S Then
  30.       xBook.Sheets("Item").Rows(i).Copy Destination:=Worksheets("Item").Rows(Q)
  31.       Q = Q + 1
  32.    End If
  33. Next i

  34. 12: If Re = True Then xBook.Close 0
  35. 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    時間: 2025-12-23 09:33

有兩個Excel,
本檔,Inv 表 M1儲存格 是 Invoice no
本檔,Rack 表 複製目的地 Row 2 開始
本檔,Item  ...
198188 發表於 2025-12-22 17:57



附上範例。
作者: 198188    時間: 2025-12-23 10:32

附上範例。
198188 發表於 2025-12-23 09:33


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

  1. Option Explicit

  2. Sub Copy_Rack_Item()

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

  4. Worksheets("Rack").Range("A2:O65600").Delete
  5. Worksheets("Item").Range("A2:O65600").Delete


  6. Application.ScreenUpdating = False

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

  19. With xBook.Sheets("Rack")
  20.    For i = 2 To xBook.Sheets("Rack").Cells(Rows.count, "A").End(xlUp).Row
  21.       If xBook.Sheets("Rack").Cells(i, "K") = T Then
  22.          xBook.Sheets("Rack").Rows(i).Copy Sheets("Rack").Rows(n)
  23.          n = n + 1
  24.       End If
  25.    Next i
  26. End With

  27. T1 = Sheets("Rack").[A2]
  28. m = 2
  29. With xBook.Sheets("Item")
  30.    For i = 2 To xBook.Sheets("Item").Cells(Rows.count, "A").End(xlUp).Row
  31.       If xBook.Sheets("Item").Cells(i, "A") = T1 Then
  32.          xBook.Sheets("Item").Rows(i).Copy Sheets("Item").Rows(m)
  33.          m = m + 1
  34.       End If
  35.    Next i
  36. End With

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


修改了這個代碼,速度快了一些,不過還是要幾分鐘。不知道這個速度是否最快。
Rack 的數據有2萬行
Item 的數據有20萬行
作者: xyz66217    時間: 2025-12-26 04:59     標題: Girls In Your City - Anonymous Sex Dating - No Selfie

Womens In Your Town - No Selfie - Anonymous Casual Dating
https://SecreLocal.com

Girls From Your Town  - Anonymous Casual Dating - No Selfie




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