Sub test()
Dim Arr, Ar(), xD, a, n%, T, sh$, wb As Workbook, ws As Worksheet
Tm = Timer
Application.ScreenUpdating = False
a = ThisWorkbook.Path
Arr = Sheets(1).Range([b1], [c65536].End(3))
fileOrg = ActiveWorkbook.Name
Set xD = CreateObject("Scripting.Dictionary")
Set fs = CreateObject("Scripting.FileSystemObject")
a = ThisWorkbook.Path
Set f = fs.GetFolder(a)
Set fc = f.Files
For Each f1 In fc
T = Replace(Split(f1.Name, ".")(0), " ", "")
xD(T) = f1.Path
Next
C = 1
For i = 3 To UBound(Arr)
T = Replace(Arr(i, 1), " ", "")
If xD.Exists(T) Then
Set wb = Workbooks.Open(xD(T))
sh = Arr(i, 2)
On Error Resume Next
Set ws = Worksheets(sh)
If Err <> 0 Then
wb.Close
Sheets(1).Cells(i, 6) = "工作表名稱有錯誤"
Err.Clear: GoTo 99
End If
With Sheets(sh)
If .FilterMode Then .ShowAllData
Drr = .Range(.[m1], .[a65536].End(3))
s = s + 1
End With
wb.Close
Sheets("集中").Cells(1, C).Resize(UBound(Drr), 13) = Drr
C = C + 13
Else
Sheets(1).Cells(i, 6) = "檔名有錯誤"
End If
99: Next
Application.ScreenUpdating = True
Set wb = Nothing: Set ws = Nothing
MsgBox Timer - Tm
End Sub作者: oak0723-1 時間: 2021-10-19 07:05
