[發問] 2個sheet 之間的資料複製,如何縮減時間

morris_lth

用For / Next 執行 sh3  複製到 sh4 , 若有500列的資料複製需要10秒,
是否有較快速的寫法,避免將來資料超過數千筆,要花上好幾分鐘才能跑完.

Set sh3 = Sheets("Source")
Set sh2 = Sheets("Target")
  
  Application.ScreenUpdating = False ' 關閉螢幕更新
  
  FinalRow = sh3.Range("A" & Rows.Count).End(xlUp).Row '計算原始SHEET有多少ROW
    sh2.[A4:Z1000].Delete Shift:=xlToLeft                                         '清除Sh2(Target)
        For  i = 2 To FinalRow
               sh3.Cells(i, 28).Copy sh2.Cells(i + 2, 1)                                        '前面數字=來源檔的列
               sh3.Cells(i, 10).Copy sh2.Cells(i + 2, 2)                                        '後面數字=目的檔的列
               sh3.Cells(i, 7).Copy sh2.Cells(i + 2, 3)
               sh3.Cells(i, 26).Copy sh2.Cells(i + 2, 4)
               sh3.Cells(i, 5).Copy sh2.Cells(i + 2, 6)
               sh3.Cells(i, 13).Copy sh2.Cells(i + 2, 7)
               sh3.Cells(i, 2).Copy sh2.Cells(i + 2, 8)
               sh3.Cells(i, 21).Copy sh2.Cells(i + 2, 9)
               sh3.Cells(i, 24).Copy sh2.Cells(i + 2, 10)
               sh3.Cells(i, 19).Copy sh2.Cells(i + 2, 14)
   Next

謝謝

morris_lth

經過幾天的學習終於弄懂且完成,7百多筆的資料原本要花15秒,
現在不用2秒即可完成,謝謝准提部林的協助.

准提部林

Sub test99()
Dim Arr, Brr, Cr1, Cr2
Set sh3 = Sheets("Source")
Set sh2 = Sheets("Target")
Arr = Range(sh3.Cells(1, 28), sh3.Cells(Rows.Count, 1).End(xlUp))
ReDim Brr(1 To UBound(Arr), 1 To 14)
Cr1 = Array(28, 10, 7, 26, 5, 13, 2, 21, 24, 19)
Cr2 = Array(1, 2, 3, 4, 6, 7, 8, 9, 10, 14)
sh2.[A4:Z1000].Delete Shift:=xlToLeft
For i = 2 To UBound(Arr)
    For j = 0 To UBound(Cr1)
        Brr(i - 1, Cr2(j)) = Arr(i, Cr1(j))
    Next j
Next i
sh2.[A4].Resize(UBound(Brr), 14) = Brr
End Sub


'===================================