先試試以下修改碼（只修改Ｃ欄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作者: 准提部林 時間: 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作者: spermbank 時間: 2015-12-23 11:58
使用〔區段〕處理，Ｃ欄〔從小到大〕為一個區段：
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
