將多個EXCEL 匯到一個EXCEL的問題 - Excel程式區

帖子: 4901
主題: 44
精華: 24
積分: 4916
點名: 142
作業系統: Windows 7
軟體版本: Office 20xx
閱讀權限: 150
性別: 男
來自: 台北
註冊時間: 2010-4-30
最後登錄: 2026-7-16

2025年全勤獎章 2024年全勤獎章 2023年全勤獎章 2022虎年全勤獎章 2021牛年全勤獎章 2020鼠年全勤獎章 2019 豬年全勤獎章 2018 狗年全勤獎章 2017 雞年全勤獎章 2016猴年全勤獎章 2015羊年全勤獎章 2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章論壇貢獻勳章熱心公益勳章 2011兔年全勤獎章

1^# 跳轉到 »

發表於 2012-4-14 10:41 | 顯示全部帖子

回復 1# yanto913

Sub test()
Dim sht()
Application.ScreenUpdating = False '關閉螢幕更新
fd = ThisWorkbook.Path & "\" '檔案所在目錄
fs = fd & "*.xls"
fb = Dir(fs)
Do Until fb = "" '所有xls檔案迴圈
If fb <> ThisWorkbook.Name Then
With Workbooks.Open(fd & fb)
Set sh = .Sheets(1)
ReDim Preserve sht(s) '記住所有工作表名稱
sht(s) = sh.Name
s = s + 1
sh.Copy after:=ThisWorkbook.Sheets(1) '複製工作表
.Close 0 '關閉檔案
End With
End If
fb = Dir
Loop
Sheets(sht).Move '移動所有複製的工作表到新檔案
Application.ScreenUpdating = True '恢復螢幕更新
End Su

複製代碼

學海無涯_不恥下問

TOP

Hsieh

超級版主 Rank: 8 Rank: 8

帖子: 4901
主題: 44
精華: 24
積分: 4916
點名: 142
作業系統: Windows 7
軟體版本: Office 20xx
閱讀權限: 150
性別: 男
來自: 台北
註冊時間: 2010-4-30
最後登錄: 2026-7-16

2025年全勤獎章 2024年全勤獎章 2023年全勤獎章 2022虎年全勤獎章 2021牛年全勤獎章 2020鼠年全勤獎章 2019 豬年全勤獎章 2018 狗年全勤獎章 2017 雞年全勤獎章 2016猴年全勤獎章 2015羊年全勤獎章 2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章論壇貢獻勳章熱心公益勳章 2011兔年全勤獎章

2^#

發表於 2012-4-14 12:35 | 顯示全部帖子

回復 8# yanto913

看你A1:A5的檔名樣式為何?是否包含資料夾目錄或副檔名
不同資料有不同處理方式，以樓上的程式碼去加判斷式應該不是很難的

學海無涯_不恥下問

TOP

Hsieh

超級版主 Rank: 8 Rank: 8

帖子: 4901
主題: 44
精華: 24
積分: 4916
點名: 142
作業系統: Windows 7
軟體版本: Office 20xx
閱讀權限: 150
性別: 男
來自: 台北
註冊時間: 2010-4-30
最後登錄: 2026-7-16

2025年全勤獎章 2024年全勤獎章 2023年全勤獎章 2022虎年全勤獎章 2021牛年全勤獎章 2020鼠年全勤獎章 2019 豬年全勤獎章 2018 狗年全勤獎章 2017 雞年全勤獎章 2016猴年全勤獎章 2015羊年全勤獎章 2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章論壇貢獻勳章熱心公益勳章 2011兔年全勤獎章

3^#

發表於 2012-4-14 14:29 | 顯示全部帖子

回復 10# LeafYeung
On Error 陳述式
一個「啟動的」錯誤處理程式是由 On Error 陳述式所打開的；一個「動作中」的錯誤處理程式是一個已啟動的錯誤處理程式正在處理錯誤。如果錯誤處理程式在動作中又發生了錯誤，(在錯誤發生和 Resume，Exit Sub，Exit Function，或 Exit Property 陳述式之間)，那麼現在此程序的錯誤處理程式將無法再處理此錯誤。
所以，要處理可能產生多次錯誤的程序，必須是Resume Next，而要繼續處理就必須清除當前錯誤物件
執行下面程序當可了解錯誤後處理狀態

Sub test1()
For i = 1 To 10
k = Int((2 - 0 + 1) * Rnd + 0)
On Error GoTo AAA '錯誤時跳至
B = i / k '製造錯誤
Next
AAA:
MsgBox "被除數等於=" & i & "除數等於=" & k
Err.Clear
Resume Next
End Sub

複製代碼

學海無涯_不恥下問

TOP

Hsieh

超級版主 Rank: 8 Rank: 8

帖子: 4901
主題: 44
精華: 24
積分: 4916
點名: 142
作業系統: Windows 7
軟體版本: Office 20xx
閱讀權限: 150
性別: 男
來自: 台北
註冊時間: 2010-4-30
最後登錄: 2026-7-16

2025年全勤獎章 2024年全勤獎章 2023年全勤獎章 2022虎年全勤獎章 2021牛年全勤獎章 2020鼠年全勤獎章 2019 豬年全勤獎章 2018 狗年全勤獎章 2017 雞年全勤獎章 2016猴年全勤獎章 2015羊年全勤獎章 2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章論壇貢獻勳章熱心公益勳章 2011兔年全勤獎章

4^#

發表於 2012-4-14 16:57 | 顯示全部帖子

回復 13# yanto913

程式設計應盡量避免錯誤產生才是正道

Sub test()
Dim sht()
Application.ScreenUpdating = False '關閉螢幕更新
fd = ThisWorkbook.Path & "\" '檔案所在目錄
For Each a In [A1:A5]
fs = fd & a & ".xls"
fb = Dir(fs)
If fb <> "" Then
a.Offset(, 1) = "OK"
With Workbooks.Open(fd & fb)
Set sh = .Sheets(1)
ReDim Preserve sht(s) '記住所有工作表名稱
sht(s) = sh.Name
s = s + 1
sh.Copy after:=ThisWorkbook.Sheets(1) '複製工作表
.Close 0 '關閉檔案
End With
End If
Next
Sheets(sht).Move '移動所有複製的工作表到新檔案
Application.ScreenUpdating = True '恢復螢幕更新
End Sub

複製代碼

學海無涯_不恥下問

TOP

[發問] 將多個EXCEL 匯到一個EXCEL的問題

[收藏此主題] [關注此主題的新回復]

[通過 QQ、MSN 分享給朋友]