標題: 資料彙總 [打印本頁]

---

作者: 蘿蔔泥    時間: 2022-2-9 16:14     標題: 資料彙總

修改後出現程式錯誤，請問我該如何修改呢？
目的是將訓練需求裡的所有Excel檔sheet2資料彙總到總表

1. Sub 匯總()
   
2. Dim myfile, mypath, wkb
   
3. 'Application.ScreenUpdating = False   '關閉螢幕更新
   
4. Sheets("總表").UsedRange.Offset(1, 0).Clear  '清除表頭之外的所有內容
   
5. mypath = Sheets("設定頁").Range("b9")           '找到目前活頁簿的路徑
   
6. MsgBox (mypath)
   
7. myfile = Dir(mypath & "\*.xls*")     '瀏覽目前資料夾下的Excel文件
   
8. MsgBox (myfile)
   
9. Do While myfile <> ""                '當找到的文件不為空時
   
10. If myfile <> ThisWorkbook.Name Then  '當找到的文件不是目前Excel活頁簿時
    
11. Set wkb = GetObject(mypath & "\" & myfile)   '得到dir找到的活頁簿的內容，設為wkb
    
12. With wkb.Sheets(2)              '對找到的活頁簿的sheet1進行操作
    
13. '複製wkb的sheet1除第一列的所有內容
    
14. .UsedRange.Offset(6, 0).Copy Sheet2.Range("A6:I25")
    
15. End With
    
16. wkb.Close False      '關閉wkb活頁簿且不儲存
    
17. End If
    
18. myfile = Dir         '尋找下一個Excel活頁簿
    
19. Loop
    
20. 'Application.ScreenUpdating = True   '恢復螢幕更新
    
21. End Sub

複製代碼

---

作者: samwang    時間: 2022-2-9 17:39

回復 1# 蘿蔔泥

請測試看看，謝謝
Sub 匯總()
Dim Arr, x&, R%
Application.ScreenUpdating = False   '關閉螢幕更新
Application.DisplayAlerts = False
Sheets("總表").UsedRange.Offset(1, 0).Clear  '清除表頭之外的所有內容
With Application.FileDialog(msoFileDialogOpen)
    .InitialFileName = "D:\"
    .AllowMultiSelect = True
    .Title = "======= 選擇來源的檔案 ========"
    .Show
    If .SelectedItems.Count = 0 Then Exit Sub
    Tm = Timer
    For x = 1 To .SelectedItems.Count
        FPath = .SelectedItems(x)
        With Workbooks.Open(FPath)
            With Sheets(2)
                Arr = .Range("a6:h" & .[A65536].End(3).Row)
            End With
            .Close
        End With
        R = Sheets("總表").[d65536].End(xlUp).Row + 1
        Sheets("總表").Range("d" & R).Resize(UBound(Arr), UBound(Arr, 2)) = Arr
    Next
End With
MsgBox Timer - Tm & "秒"
Application.ScreenUpdating = True   '恢復螢幕更新
Application.DisplayAlerts = True
End Sub

---

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