[發問] 複製超級慢問題求救

spermbank

大家好:

         我想利用"工作表1"的A欄代號至"首頁"及"基本面"搜尋複製(包含原本數值、格式及顏色)相關資料至"工作表1"
         我利用office 2007跑，速度超級慢，起碼要20-30分鐘，可是用office 2010(不同電腦，電腦比較好)跑只要8-10分鐘
         基本上都用office 2007跑，想請教各位大大，這要如何解決(如附件檔案)，感謝。

spermbank

這是我的程式碼麻煩大大幫我看看，感謝。

1. Sub Macro1()
   
2. 
   
3. 
   
4.     Sheets("工作表1").Select
   
5.     x1 = Application.WorksheetFunction.CountA(Range("A:A")) '欄位有值範圍計
   
6. '================================================================
   
7. '    iStart = Timer
   
8. '================================================================
   
9.    
   
10. 
    
11.     For i = 2 To x1            '利用工作表1A欄代號至首頁、基本面尋找相對代號
    
12.         Range("C" & i).Formula = "=MATCH($A" & i & ",首頁!$A$1:$A$3000,)"
    
13.     Next
    
14.    
    
15.    
    
16.     Columns("C:C").Select       '將公式轉換成值
    
17.     Selection.Copy
    
18.     Range("C1").Select
    
19.     Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    
20.         :=False, Transpose:=False
    
21.     Application.CutCopyMode = False
    
22.     Range("C1").Select
    
23. 
    
24. 
    
25. 
    
26. 
    
27.     For i = 2 To x1     '利用工作表1C欄的值，至首頁及基本面捉取相關資料
    
28. 
    
29.         GGG = Cells(i, "C")
    
30.         Sheets("首頁").Range("F" & GGG & ":" & "P" & GGG).Copy Sheets("工作表1").Range("D" & i & ":" & "N" & i)
    
31. 
    
32. 
    
33.         Sheets("基本面").Range("G" & GGG & ":" & "I" & GGG).Copy Sheets("工作表1").Range("O" & i & ":" & "Q" & i)
    
34. 
    
35. 
    
36.         Sheets("基本面").Range("D" & GGG & ":" & "E" & GGG).Copy Sheets("工作表1").Range("R" & i & ":" & "S" & i)
    
37. 
    
38. 
    
39.         Sheets("基本面").Range("E" & GGG & ":" & "E" & GGG).Copy Sheets("工作表1").Range("T" & i & ":" & "T" & i)
    
40. 
    
41. 
    
42.         Sheets("基本面").Range("F" & GGG & ":" & "F" & GGG).Copy Sheets("工作表1").Range("U" & i & ":" & "U" & i)
    
43. 
    
44.     Next
    
45. 
    
46. 
    
47. 
    
48. 
    
49. 
    
50. '================================================================
    
51. '    iEnd = Timer
    
52. '    Sheets("工作表1").Select
    
53. '    Cells(2, "F") = iEnd - iStart
    
54. 
    
55. End Sub

複製代碼

准提部林

2007跑，速度超級慢，起碼要20-30分鐘？　

不到４００筆，應不致如此久！！！
除非實際檔案中還有其它工作表，且帶有大量公式，造成每貼一次資料，即自動重算一次！

使用UNION集成之後再貼資料，會快很多，但所上傳的檔案中，工作表１的Ａ欄代號有很多重覆，無法使用此法！！

先試試以下修改碼（只修改Ｃ欄MATCH公式），在XP+2000中約一分鐘可成（３８６列）：
Sub Macro1()
Dim G&, TM, i&
TM = Time
Sheets("工作表1").Select
x1 = Application.WorksheetFunction.CountA(Range("A:A"))
Range("D2:U" & x1).Clear
With Range("C2:C" & x1)
　　　.Formula = "=MATCH(A2,首頁!$A$1:$A$3000,)"
　　　.Value = .Value
End With
Application.ScreenUpdating = False
For i = 2 To x1
　　　G = Cells(i, "C")
　　　Sheets("首頁").Range("F" & G & ":" & "P" & G).Copy Sheets("工作表1").Range("D" & i)   'D-N
　　　Sheets("基本面").Range("G" & G & ":" & "I" & G).Copy Sheets("工作表1").Range("O" & i) 'O-Q
　　　Sheets("基本面").Range("D" & G & ":" & "E" & G).Copy Sheets("工作表1").Range("R" & i)  'R-S
　　　Sheets("基本面").Range("E" & G).Copy Sheets("工作表1").Range("T" & i)
　　　Sheets("基本面").Range("F" & G).Copy Sheets("工作表1").Range("U" & i)
Next
MsgBox "完成時間" & Format(Time - TM, "hh:mm:ss")
End Sub

准提部林

將Ａ欄重覆代號先刪除，再試試：（注意：所有表格的代號必須先排序）　
Sub Macro2()
Dim G&, TM, i&, xU(1 To 5) As Range, xR As Range, x1&
TM = Time
Sheets("工作表1").Select
x1 = Application.WorksheetFunction.CountA(Range("A:A"))
Range("D2:U" & x1).Clear
　
With Range("C2:C" & x1)
　　　.Formula = "=MATCH(A2,首頁!$A$1:$A$3000,)"
　　　.Value = .Value
End With
　
Application.ScreenUpdating = False
For i = 2 To x1
　　G = Cells(i, "C")
　　Set xR = Sheets("首頁").Range("F" & G & ":" & "P" & G)
　　If i = 2 Then Set xU(1) = xR Else Set xU(1) = Union(xU(1), xR)
　
　　Set xR = Sheets("基本面").Range("G" & G & ":" & "I" & G)
　　If i = 2 Then Set xU(2) = xR Else Set xU(2) = Union(xU(2), xR)
　　   
　　Set xR = Sheets("基本面").Range("D" & G & ":" & "E" & G)
　　If i = 2 Then Set xU(3) = xR Else Set xU(3) = Union(xU(3), xR)
    　
　　Set xR = Sheets("基本面").Range("E" & G)
　　If i = 2 Then Set xU(4) = xR Else Set xU(4) = Union(xU(4), xR)
    　
　　Set xR = Sheets("基本面").Range("F" & G)
　　If i = 2 Then Set xU(5) = xR Else Set xU(5) = Union(xU(5), xR)
Next
　
For i = 1 To 5
　　xU(i).Copy Range(Array("D2", "O2", "R2", "T2", "U2")(i - 1))
Next i
MsgBox "完成時間" & Format(Time - TM, "hh:mm:ss")
End Sub

spermbank

回復 4# 准提部林

准提部林 您好:

    有沒有辦法不刪除A欄重複代號及重新排列方式下完成呢?
    沒有秀出完整程式，但重複代號及所在位置有其意義，感謝。

准提部林

使用〔區段〕處理，Ｃ欄〔從小到大〕為一個區段：
Sub 執行()
Dim G&, TM, i&, j%, R&
TM = Time
Sheets("工作表1").Select
R = Cells(Rows.Count, 1).End(xlUp).Row
With Range("C2:C" & R): .Formula = "=MATCH(A2,首頁!A$1:A$3000,)": .Value = .Value: End With
Application.ScreenUpdating = False
Dim xU(1 To 4) As Range, xR(1 To 4) As Range, X&, N&
X = 1: N = 2
RE_GET:
For i = X + 1 To R
　　G = Cells(i, "C")
　　Set xR(1) = [首頁!F1:P1].Offset(G - 1, 0)
　　Set xR(2) = [基本面!G1:I1].Offset(G - 1, 0)
　　Set xR(3) = [基本面!D1:E1].Offset(G - 1, 0)
　　Set xR(4) = [基本面!E1:F1].Offset(G - 1, 0)
　　For j = 1 To 4
　　　　If xU(j) Is Nothing Then Set xU(j) = xR(j) Else Set xU(j) = Union(xU(j), xR(j))
　　Next j
　　If G >= Cells(i + 1, "C") Then X = i: Exit For
Next
For j = 1 To 4
　　xU(j).Copy Range(Array("D1", "O1", "R1", "T1")(j - 1)).Cells(N, 1)
　　Set xU(j) = Nothing: Set xR(j) = Nothing
Next j
N = X + 1
If X < R Then GoTo RE_GET
MsgBox "完成時間" & Format(Time - TM, "hh:mm:ss")
End Sub

附檔下載：
Xl0000231.rar (231.44 KB)

下載次數: 5

2015-12-23 14:33

　

spermbank

回復 6# 准提部林


    准提部林 您好:

     請問一下取區段最小時，工作表1都會標示A至C欄最小為黃底色，這黃底色能夠拿掉嗎??
     因為底色註記，還有其他用途，從程式看不出來怎麼拿掉，感謝。

     另外，我的程式是
     Sub test()
         .
         .(上段程式)(有判斷式子、給儲存格顏色)
         .
         複製部分(中段程式)
         .
         .(下段程式)(同一分頁有運算)
         .
     endsub

     上段程式、中段程式、下段程式都依序處理，這樣子真的會影響複製部分呀，可是我不知道為什麼?

准提部林

回復 7# spermbank


那底色是〔格式化條件〕，清除即可，與程式無關～～
只能提供複製部份，
所提上下段程式是否有相衝突或影響，無法判斷，請自行先套看看～～

spermbank

回復 8# 准提部林

Ok,感謝感謝^^