- 帖子
- 104
- 主題
- 10
- 精華
- 0
- 積分
- 114
- 點名
- 0
- 作業系統
- Windows 10
- 軟體版本
- Office 2007
- 閱讀權限
- 20
- 性別
- 男
- 註冊時間
- 2021-6-21
- 最後登錄
- 2021-8-24
|
45#
發表於 2021-7-7 09:03
| 只看該作者
回復 44# samwang
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.AskToUpdateLinks = False
fileorg = ActiveWorkbook.Name
Set xD = CreateObject("Scripting.Dictionary")
For i1 = 1 To n1
If Not xD.Exists(Ar(i1, 1) & "") Then
xD(Ar(i1, 1) & "") = ""
For i = 1 To n
If Arr(i, 2) = Ar(i1, 1) Then n2 = n2 + 1: Ar1(n2, 1) = Arr(i, 1)
Next
End If
Next
R = 1: Sheets("6月份數據").Select
With Sheets("6月份數據")
If .FilterMode Then .ShowAllData
.Range("a1:AA" & .[a65536].End(3).Row).Delete
Tm = Timer
For i1 = 1 To n2
Set WB = Workbooks.Open(Ar1(i1, 1))
With Sheets("6月份數據")
If .FilterMode Then .ShowAllData
fn = Split(ActiveWorkbook.Name, ".")(0)
.Range("a1:z" & .[a65536].End(3).Row).Copy Workbooks(fileorg).Sheets("6月份數據").Range("a" & R)
End With
WB.Close
.Range("U" & R & ":U" & .[a65536].End(xlUp).Row) = fn
R = .[a65536].End(xlUp).Row + 1
Next
End With
MsgBox "資料複製完成" & Timer - Tm & "秒"
Erase Arr: Erase Ar
Unload Me
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.AskToUpdateLinks = True
複製資料的時候
Set WB = Workbooks.Open(Ar1(i1, 1))
這行出現了錯誤
|
|
