如何一次將多個Excel檔案copy到一個檔案內的不同工作表中

imingho

有時候我們會把Excel分類請不同人幫忙輸入，但是輸入完時，都是各別檔案，如果要把它copy成一個檔案就很麻煩，底下這個VBA程式，就是在處理這種情形的工具。


說明網址:http://272586.blogspot.tw/2008/07/excelcopy_31.html


2016/7/21        修正因【加入自定剖析符號】造成選取檔案時列數錯誤
2016/5//16        加入自定剖析符號
2016/3/5        加入關閉提示，解決有公式時合併會出現要不要儲存檔的對話框
2013/8/1        加入可以選取檔案的功能,取消檔案類型(副檔名)




檔案名稱:mergertosheet_v4.xls

免費下載mergertosheet_v4.xls:http://bestdaylong.com/download.php?id=14

Excel 2007 版本下載處
http://discuz.bestdaylong.com/fo ... &tid=1529&fromuid=2

1.執行畫面

imingho

2016/5//16        加入自定剖析符號

imingho

1. 
   
2. Private Sub cmdClearData_Click()
   
3.     Sheet1.Range("A5:B65535").Clear '將舊的A-B欄資料清除
   
4. End Sub
   
5. 
   
6. Private Sub cmdMerge_Click()
   
7.     Dim objsheet As Worksheet
   
8.    
   
9.    
   
10.     WorkName = Excel.ActiveWorkbook.Name '此檔案名稱
    
11.    
    
12.    
    
13.     Excel.Workbooks.Add '開新的workbook
    
14.    
    
15.     desc = Excel.ActiveWorkbook.Name   '新檔案視窗編號
    
16.    
    
17.    
    
18.     i = 5
    
19.     While Windows(WorkName).ActiveSheet.Range("b" & i) <> ""
    
20.         
    
21.         
    
22.         Filename = Windows(WorkName).ActiveSheet.Range("b" & i)
    
23.         
    
24.         n = InStr(1, Filename, ".")
    
25.         
    
26.         strFileName = Left(Filename, n - 1) '檔案名稱
    
27.         strsFileType = Mid(Filename, n + 1) '檔案類型
    
28.         
    
29.         
    
30.         
    
31.         If Windows(WorkName).ActiveSheet.Range("a" & i) = "" Then
    
32.             Fullpath = Excel.Workbooks(WorkName).Path & "\" & Filename
    
33.         Else
    
34.             Fullpath = Windows(WorkName).ActiveSheet.Range("a" & i) & Filename
    
35.         End If
    
36.         
    
37.         '檢查檔案是否存在
    
38.         If Dir(Fullpath) = "" Then
    
39.             MsgBox "檔案:" & Fullpath & "不存在，請查看是否有拼錯字"
    
40.             Exit Sub    '離開程式
    
41.         Else
    
42.             Workbooks.Open Filename:=Fullpath
    
43.         End If
    
44.         
    
45.         
    
46.         If UCase(strsFileType) = "XLS" Then
    
47.            Workbooks.Open Filename:=Fullpath    '開啟檔案
    
48.         Else
    
49.              If UCase(Windows(WorkName).ActiveSheet.Range("b1")) = "N" Then
    
50.                 Workbooks.OpenText Filename:=Fullpath, Origin:=Windows(WorkName).ActiveSheet.Range("b2"), _
    
51.                 StartRow:=1, DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, _
    
52.                 ConsecutiveDelimiter:=False, Tab:=False, Semicolon:=False, Comma:=False _
    
53.                 , Space:=False, Other:=False, FieldInfo:=Array(1, 1), _
    
54.                 TrailingMinusNumbers:=True
    
55.             Else
    
56.                 Workbooks.OpenText Filename:=Fullpath, Origin:=Windows(WorkName).ActiveSheet.Range("b2"), _
    
57.                 DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, _
    
58.                 ConsecutiveDelimiter:=True, Tab:=True, Semicolon:=False, Comma:=False, _
    
59.                 Space:=True
    
60.             End If
    
61.         End If
    
62.         
    
63.         sheetname = Windows(WorkName).ActiveSheet.Range("b3")
    
64.         
    
65.         If sheetname <> "" Then
    
66.             
    
67.             '檢查活頁是否存在
    
68.             flag = 0
    
69.             For j = 1 To Windows(Filename).Parent.Sheets.Count
    
70.                 If Windows(Filename).Parent.Sheets(j).Name = sheetname Then
    
71.                    flag = 1
    
72.                    Exit For
    
73.                 End If
    
74.             Next
    
75.             
    
76.             If flag = 1 Then
    
77.                 Windows(Filename).Parent.Sheets(sheetname).Select  '切換活頁
    
78.             End If
    
79.                
    
80.         End If
    
81.         Set objsheet = Windows(Filename).ActiveSheet '切換視窗
    
82.         
    
83.         '選取來源範圍
    
84.          objsheet.Cells.Select
    
85.          'copy
    
86.          Selection.Copy
    
87.         
    
88.         Windows(desc).Activate '切換視窗
    
89.         
    
90.         Sheets.Add after:=Worksheets(Worksheets.Count)  '增加活頁
    
91.         ActiveSheet.Paste   '貼上
    
92.         ActiveSheet.Range("A1").Select  '將選取範圍取消
    
93.         
    
94. 
    
95.         ActiveSheet.Name = strFileName     '將活頁名稱改成檔案名稱
    
96. 
    
97. 
    
98.         '避免copy太多資料時,要關閉檔案時.會問記憶體的資料是否要保留
    
99.         ActiveSheet.Range("A1").Copy
    
100.         
     
101.        '將來源檔案關閉
     
102.        Windows(Filename).Close
     
103.         
     
104.         i = i + 1 '讀取下一個檔案名稱
     
105.     Wend
     
106.     MsgBox "已將所有檔案匯入活頁中", , "彰化一整天的Blog http://272586.blogspot.com"
     
107. End Sub
     
108. 
     
109. Private Sub cmdSelectFile_Click()
     
110.     Dim fd As FileDialog    '宣告一個檔案對話框
     
111.    
     
112.     Set fd = Excel.Application.FileDialog(msoFileDialogFilePicker)  '設定選取檔案功能
     
113.    
     
114.    
     
115.     fd.Filters.Clear    '清除之前的資料
     
116.    
     
117.     fd.Filters.Add "Excel File", "*.xls*" '設定顯示的副檔名
     
118.     fd.Filters.Add "Word File", "*.txt"
     
119.     fd.Filters.Add "Word File", "*.csv"
     
120.     fd.Filters.Add "所有檔案", "*.*"
     
121.    
     
122.     fd.Show '顯示對話框
     
123.    
     
124.     str_row = Range("b1").End(xlDown).Row '開始列前一筆(最後一筆非空白資料的列數)
     
125.    
     
126.    
     
127.    
     
128.     For i = 1 To fd.SelectedItems.Count
     
129.         strFullName = fd.SelectedItems(i)
     
130. 
     
131.         
     
132.         
     
133.         n = rinstr(strFullName, "\")
     
134.         
     
135.         strFileNameType = Mid(strFullName, n + 1)
     
136.         
     
137.         strFullPath = Left(strFullName, n)
     
138.         Sheet1.Cells(i + str_row, 1) = strFullPath '顯示所選取的檔案路徑
     
139.         
     
140. 
     
141.         n = InStr(1, strFileNameType, ".")
     
142.         
     
143.         strFileName = Left(strFileNameType, n - 1)
     
144.         strsFileType = Mid(strFileNameType, n + 1)
     
145.         
     
146.         Sheet1.Cells(i + str_row, 2) = strFileNameType
     
147. 
     
148.         
     
149.     Next
     
150. End Sub
     
151. 
     
152. Function rinstr(ByVal t As String, ByVal s As String)
     
153.     '自訂函數找尋某個字串最後出現的位置
     
154.     Dim i As Integer
     
155.     Dim n As Integer
     
156.    
     
157.     n = 0
     
158.     For i = 1 To Len(t)
     
159.         If Mid(t, i, 1) = s Then
     
160.            n = i
     
161.         End If
     
162.     Next
     
163.     rinstr = n
     
164. End Function
     
165. 
     

複製代碼

susuman

太實用的，
謝謝分享

xp88

thank for your share

no8

如果可以這樣的話 真的很方便耶
超省時的

lager

可以選檔案位址. 這樣實在方便太多搂

boy978880

這個時在是太方便了!!感覺VBA有點深澳，慢慢研究

necsony

謝謝分享，精進自已的程式能力

bao

謝謝imingho大大，剛好有用到，好用

altosax

這實在是太實用了!!非常感謝您的分享~~