返回列表 上一主題 發帖

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

spermbank

帖子
94 
主題
28 
精華
0 
積分
145 
點名
0  
作業系統
windows 
軟體版本
office 2007 
閱讀權限
20 
註冊時間
2011-9-22 
最後登錄
2021-10-18 
1# 跳轉到 » 倒序看帖
打印
tT
發表於 2015-12-22 23:36 | 只看該作者

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

本帖最後由 spermbank 於 2015-12-22 23:42 編輯

大家好:

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

test.rar (395.38 KB)

收藏 分享

spermbank

帖子
94 
主題
28 
精華
0 
積分
145 
點名
0  
作業系統
windows 
軟體版本
office 2007 
閱讀權限
20 
註冊時間
2011-9-22 
最後登錄
2021-10-18 
2#
發表於 2015-12-23 09:28 | 只看該作者
這是我的程式碼麻煩大大幫我看看，感謝。
  1. Sub Macro1()


  4.     Sheets("工作表1").Select
  5.     x1 = Application.WorksheetFunction.CountA(Range("A:A")) '欄位有值範圍計
  6. '================================================================
  7. '    iStart = Timer
  8. '================================================================
  9.    

  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




  27.     For i = 2 To x1     '利用工作表1C欄的值，至首頁及基本面捉取相關資料

  29.         GGG = Cells(i, "C")
  30.         Sheets("首頁").Range("F" & GGG & ":" & "P" & GGG).Copy Sheets("工作表1").Range("D" & i & ":" & "N" & i)


  33.         Sheets("基本面").Range("G" & GGG & ":" & "I" & GGG).Copy Sheets("工作表1").Range("O" & i & ":" & "Q" & i)


  36.         Sheets("基本面").Range("D" & GGG & ":" & "E" & GGG).Copy Sheets("工作表1").Range("R" & i & ":" & "S" & i)


  39.         Sheets("基本面").Range("E" & GGG & ":" & "E" & GGG).Copy Sheets("工作表1").Range("T" & i & ":" & "T" & i)


  42.         Sheets("基本面").Range("F" & GGG & ":" & "F" & GGG).Copy Sheets("工作表1").Range("U" & i & ":" & "U" & i)

  44.     Next





  50. '================================================================
  51. '    iEnd = Timer
  52. '    Sheets("工作表1").Select
  53. '    Cells(2, "F") = iEnd - iStart

  55. End Sub
複製代碼

TOP

准提部林

帖子
2804 
主題
10 
精華
0 
積分
2860 
點名
0  
作業系統
〔略〕 
軟體版本
〔略〕 
閱讀權限
100 
性別
男 
來自
〔略〕 
註冊時間
2013-5-13 
最後登錄
2024-5-2 
3#
發表於 2015-12-23 10:48 | 只看該作者
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

TOP

准提部林

帖子
2804 
主題
10 
精華
0 
積分
2860 
點名
0  
作業系統
〔略〕 
軟體版本
〔略〕 
閱讀權限
100 
性別
男 
來自
〔略〕 
註冊時間
2013-5-13 
最後登錄
2024-5-2 
4#
發表於 2015-12-23 10:52 | 只看該作者
本帖最後由 准提部林 於 2015-12-23 11:15 編輯

將Ａ欄重覆代號先刪除，再試試：（注意：所有表格的代號必須先排序）　
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

TOP

spermbank

帖子
94 
主題
28 
精華
0 
積分
145 
點名
0  
作業系統
windows 
軟體版本
office 2007 
閱讀權限
20 
註冊時間
2011-9-22 
最後登錄
2021-10-18 
5#
發表於 2015-12-23 11:58 | 只看該作者
回復 4# 准提部林

准提部林 您好:

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

TOP

准提部林

帖子
2804 
主題
10 
精華
0 
積分
2860 
點名
0  
作業系統
〔略〕 
軟體版本
〔略〕 
閱讀權限
100 
性別
男 
來自
〔略〕 
註冊時間
2013-5-13 
最後登錄
2024-5-2 
6#
發表於 2015-12-23 14:33 | 只看該作者
使用〔區段〕處理，Ｃ欄〔從小到大〕為一個區段：
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)
　

TOP

spermbank

帖子
94 
主題
28 
精華
0 
積分
145 
點名
0  
作業系統
windows 
軟體版本
office 2007 
閱讀權限
20 
註冊時間
2011-9-22 
最後登錄
2021-10-18 
7#
發表於 2015-12-23 16:16 | 只看該作者
本帖最後由 spermbank 於 2015-12-23 16:23 編輯

回復 6# 准提部林


    准提部林 您好:

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

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

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

TOP

准提部林

帖子
2804 
主題
10 
精華
0 
積分
2860 
點名
0  
作業系統
〔略〕 
軟體版本
〔略〕 
閱讀權限
100 
性別
男 
來自
〔略〕 
註冊時間
2013-5-13 
最後登錄
2024-5-2 
8#
發表於 2015-12-23 17:24 | 只看該作者
回復 7# spermbank


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

TOP

spermbank

帖子
94 
主題
28 
精華
0 
積分
145 
點名
0  
作業系統
windows 
軟體版本
office 2007 
閱讀權限
20 
註冊時間
2011-9-22 
最後登錄
2021-10-18 
9#
發表於 2015-12-23 20:21 | 只看該作者
回復 8# 准提部林

Ok,感謝感謝^^

TOP

        靜思自在 : 天上最美是星星，人生最美是溫情。
返回列表 上一主題