- 帖子
- 976
- 主題
- 7
- 精華
- 0
- 積分
- 1018
- 點名
- 0
- 作業系統
- Win10
- 軟體版本
- Office 2016
- 閱讀權限
- 50
- 性別
- 男
- 註冊時間
- 2013-4-19
- 最後登錄
- 2024-10-30
|
3#
發表於 2021-10-18 12:14
| 只看該作者
回復 1# oak0723-1
B、C欄如輸入錯誤則F欄會顯示錯誤(排除B欄空格問題)，請測試看看，謝謝
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 |
|
