麻辣家族討論版版 - Powered by Discuz! Board

標題: [發問] 資料夾.XLS匯整(2010版) [打印本頁]

作者: rouber590324 時間: 2022-8-23 10:00 標題: 資料夾.XLS匯整(2010版)

DEAR  ALL 大大
1.於 C:AAA\下放置  EXCEL檔  A1.XLS A2.XLS  A3.XLS............
2.EXCEL 為  2010版請問如何書寫 VBA
自動將 C:AAA\下放置之  A1.XLS A2.XLS  A3.XLS........ 匯整至單一EXCEL
3.煩不吝賜教  THANKS*10000

作者: samwang 時間: 2022-8-23 13:03

DEAR  ALL 大大
1.於 C:AAA\下放置  EXCEL檔  A1.XLS A2.XLS  A3.XLS............
2.EXCEL 為  2010版  ...
rouber590324 發表於 2022-8-23 10:00

請測試看看，謝謝
Sub test()
Dim Arr, a, fs, fc, f, f1, n&
Application.ScreenUpdating = False: Application.DisplayAlerts = False: Application.AskToUpdateLinks = False
Set fs = CreateObject("Scripting.FileSystemObject")
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = "D:\"
.Title = "選擇檔案來源資料夾"
.Show
On Error GoTo EndSub:
a = .SelectedItems(1)
End With
Tm = Timer
Set f = fs.GetFolder(a)
Set fc = f.Files
For Each f1 In fc
Set WB = Workbooks.Open(f1)
With Sheets(1)
If .FilterMode Then .ShowAllData
Arr = .Range("a1").CurrentRegion
End With
WB.Close
If [a1] = "" Then n = 1 Else n = [A65536].End(xlUp).Row + 1
Range("a" & n).Resize(UBound(Arr), UBound(Arr, 2)) = Arr
Next
Application.ScreenUpdating = True: Application.DisplayAlerts = True: Application.AskToUpdateLinks = True
MsgBox "執行完成" & Timer - Tm & " 秒"
EndSub:
End Sub

作者: rouber590324 時間: 2022-8-24 14:05

DEAR samwang大大
測試後 2002版可正確執行
2010版秀出空白

作者: samwang 時間: 2022-8-24 20:00

DEAR samwang大大
測試後 2002版可正確執行
2010版秀出空白
rouber590324 發表於 2022-8-24 14:05

我的2016也沒問題，你的2010有問題，這樣只能看其他的大大有無其它解法了，謝謝

歡迎光臨麻辣家族討論版版 (http://forum.twbts.com/)