麻辣家族討論版版 - Powered by Discuz! Board

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

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

Sub Copy_Rack_Item()
Dim Brr, Arr, i&, n&, Q&, T$, S$, MyPath$, xFile$, xBook As Workbook, Re
Worksheets("Rack").Range("A2:O65600").Delete
Worksheets("Item").Range("A2:O65600").Delete
n = 2
T = Worksheets("Inv").Range("M1")
Application.ScreenUpdating = False
MyPath = "S:\EXPORT SHIPMENT\"
xFile = "Delivery Note Input Template.xlsx"
On Error Resume Next
Set xBook = Workbooks(xFile)
If xBook Is Nothing Then
Set xBook = Workbooks.Open(MyPath & xFile, , True, , "")
Re = True: ThisWorkbook.Activate
End If
On Error GoTo 0
Brr = xBook.Sheets("Rack").UsedRange
For i = 2 To UBound(Brr)
If xBook.Sheets("Rack").Cells(i, 11) = T Then
xBook.Sheets("Rack").Rows(i).Copy Destination:=Worksheets("Rack").Rows(n)
n = n + 1
End If
Next i
Q = 2
S = Worksheets("Rack").Range("A2")
Arr = xBook.Sheets("Item").UsedRange
For i = 2 To UBound(Arr)
If xBook.Sheets("Item").Cells(i, 1) = S Then
xBook.Sheets("Item").Rows(i).Copy Destination:=Worksheets("Item").Rows(Q)
Q = Q + 1
End If
Next i
12: If Re = True Then xBook.Close 0
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

Option Explicit
Sub Copy_Rack_Item()
Dim z, Q, i&, n&, T$, T1$, MyPath$, xFile$, xBook As Workbook, Re, m
Worksheets("Rack").Range("A2:O65600").Delete
Worksheets("Item").Range("A2:O65600").Delete
Application.ScreenUpdating = False
MyPath = "S:\EXPORT SHIPMENT\"
xFile = "Delivery Note Input Template.xlsx"
On Error Resume Next
Set xBook = Workbooks(xFile)
If xBook Is Nothing Then
Set xBook = Workbooks.Open(MyPath & xFile, , True, , "")
Re = True: ThisWorkbook.Activate
End If
On Error GoTo 0
n = 2
Set z = CreateObject("Scripting.Dictionary")
T = Worksheets("Inv").Range("M1")
With xBook.Sheets("Rack")
For i = 2 To xBook.Sheets("Rack").Cells(Rows.count, "A").End(xlUp).Row
If xBook.Sheets("Rack").Cells(i, "K") = T Then
xBook.Sheets("Rack").Rows(i).Copy Sheets("Rack").Rows(n)
n = n + 1
End If
Next i
End With
T1 = Sheets("Rack").[A2]
m = 2
With xBook.Sheets("Item")
For i = 2 To xBook.Sheets("Item").Cells(Rows.count, "A").End(xlUp).Row
If xBook.Sheets("Item").Cells(i, "A") = T1 Then
xBook.Sheets("Item").Rows(i).Copy Sheets("Item").Rows(m)
m = m + 1
End If
Next i
End With
12: If Re = True Then xBook.Close 0
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/)