資料彙總
修改後出現程式錯誤，請問我該如何修改呢？目的是將訓練需求裡的所有Excel檔sheet2資料彙總到總表[code]Sub 匯總()
Dim myfile, mypath, wkb
'Application.ScreenUpdating = False '關閉螢幕更新
Sheets("總表").UsedRange.Offset(1, 0).Clear '清除表頭之外的所有內容
mypath = Sheets("設定頁").Range("b9") '找到目前活頁簿的路徑
MsgBox (mypath)
myfile = Dir(mypath & "\*.xls*") '瀏覽目前資料夾下的Excel文件
MsgBox (myfile)
Do While myfile <> "" '當找到的文件不為空時
If myfile <> ThisWorkbook.Name Then '當找到的文件不是目前Excel活頁簿時
Set wkb = GetObject(mypath & "\" & myfile) '得到dir找到的活頁簿的內容，設為wkb
With wkb.Sheets(2) '對找到的活頁簿的sheet1進行操作
'複製wkb的sheet1除第一列的所有內容
.UsedRange.Offset(6, 0).Copy Sheet2.Range("A6:I25")
End With
wkb.Close False '關閉wkb活頁簿且不儲存
End If
myfile = Dir '尋找下一個Excel活頁簿
Loop
'Application.ScreenUpdating = True '恢復螢幕更新
End Sub
[/code] [b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=118391&ptid=23579]1#[/url] [i]蘿蔔泥[/i] [/b]
請測試看看，謝謝
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
頁:
[1]