- 帖子
- 976
- 主題
- 7
- 精華
- 0
- 積分
- 1018
- 點名
- 0
- 作業系統
- Win10
- 軟體版本
- Office 2016
- 閱讀權限
- 50
- 性別
- 男
- 註冊時間
- 2013-4-19
- 最後登錄
- 2024-10-30
|
2#
發表於 2021-5-25 16:13
| 只看該作者
回復 1# john2006168
請測試看看， 謝謝。
Sub test()
Dim Arr, x%, FPath$, FD, FN, WB As Workbook, CT%, N%, M%
Application.ScreenUpdating = False
Application.AskToUpdateLinks = False
Application.DisplayAlerts = False
'========================================================================
With Application.FileDialog(msoFileDialogOpen)
.InitialFileName = "D:\"
.AllowMultiSelect = True
.Show
Tm = Timer
For x = 1 To .SelectedItems.Count
FPath = .SelectedItems(x)
filedata = ActiveWorkbook.Name
Set WB = Workbooks.Open(FPath)
With Sheets(1)
If .FilterMode Then .ShowAllData
CT = Application.CountA([A1:A6636])
If CT < 2 Then GoTo 99
M = M + 1: FD = .[C1]
Arr = .Range(.[K3], .[A65536].End(3))
FN = Split(ActiveWorkbook.Name, ".")(0)
End With
99: WB.Close
If M = 1 Then
With Sheets("Summary")
N = .Range("A65536").End(xlUp).Row + 1
.Range("A" & N).Resize(UBound(Arr), UBound(Arr, 2)) = Arr
.Range("I" & N).Resize(UBound(Arr)) = FD
.Range("K" & N).Resize(UBound(Arr)) = FN
End With
M = 0: Erase Arr
End If
Next
End With
'===========================================================================
Set WB = Nothing
Application.ScreenUpdating = True
Application.AskToUpdateLinks = True
Application.DisplayAlerts = True
MsgBox "執行完成" & Timer - Tm & " 秒"
End Sub |
|
