[發問] VBA 文件夾不同活頁簿複製到總表

本帖最後由 john2006168 於 2021-5-25 10:50 編輯

如附件有1個文件夾有幾個workbook,想將資料複製到總表,請問老師可否提供方法學習(在不打開test01& test 02).[attach]33330[/attach][attach]33333[/attach]

擷取02.PNG (19.17 KB)

擷取01.PNG (12.67 KB)

Test.zip (41.04 KB)

樓主熱帖

samwang

大學生 Rank: 4

帖子: 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

TOP

john2006168