彰化一整天的論壇

 找回密碼
 立即註冊
搜索
查看: 6854|回復: 27

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

[複製鏈接]
發表於 2013-8-1 13:28:46 | 顯示全部樓層 |閱讀模式
有時候我們會把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




mergertosheet_01.png

1.執行畫面

mergertosheet_v4.xls

58.5 KB, 下載次數: 23

售價: 2 金錢  [記錄]

mergertosheet_v4.xls

回復

使用道具 舉報

 樓主| 發表於 2016-5-16 19:54:50 | 顯示全部樓層
2016/5//16        加入自定剖析符號
回復 支持 1 反對 0

使用道具 舉報

 樓主| 發表於 2013-11-20 18:53:35 | 顯示全部樓層


  1. Private Sub cmdClearData_Click()
  2.     Sheet1.Range("A5:B65535").Clear '將舊的A-B欄資料清除
  3. End Sub

  4. Private Sub cmdMerge_Click()
  5.     Dim objsheet As Worksheet
  6.    
  7.    
  8.     WorkName = Excel.ActiveWorkbook.Name '此檔案名稱
  9.    
  10.    
  11.     Excel.Workbooks.Add '開新的workbook
  12.    
  13.     desc = Excel.ActiveWorkbook.Name   '新檔案視窗編號
  14.    
  15.    
  16.     i = 5
  17.     While Windows(WorkName).ActiveSheet.Range("b" & i) <> ""
  18.         
  19.         
  20.         Filename = Windows(WorkName).ActiveSheet.Range("b" & i)
  21.         
  22.         n = InStr(1, Filename, ".")
  23.         
  24.         strFileName = Left(Filename, n - 1) '檔案名稱
  25.         strsFileType = Mid(Filename, n + 1) '檔案類型
  26.         
  27.         
  28.         
  29.         If Windows(WorkName).ActiveSheet.Range("a" & i) = "" Then
  30.             Fullpath = Excel.Workbooks(WorkName).Path & "\" & Filename
  31.         Else
  32.             Fullpath = Windows(WorkName).ActiveSheet.Range("a" & i) & Filename
  33.         End If
  34.         
  35.         '檢查檔案是否存在
  36.         If Dir(Fullpath) = "" Then
  37.             MsgBox "檔案:" & Fullpath & "不存在,請查看是否有拼錯字"
  38.             Exit Sub    '離開程式
  39.         Else
  40.             Workbooks.Open Filename:=Fullpath
  41.         End If
  42.         
  43.         
  44.         If UCase(strsFileType) = "XLS" Then
  45.            Workbooks.Open Filename:=Fullpath    '開啟檔案
  46.         Else
  47.              If UCase(Windows(WorkName).ActiveSheet.Range("b1")) = "N" Then
  48.                 Workbooks.OpenText Filename:=Fullpath, Origin:=Windows(WorkName).ActiveSheet.Range("b2"), _
  49.                 StartRow:=1, DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, _
  50.                 ConsecutiveDelimiter:=False, Tab:=False, Semicolon:=False, Comma:=False _
  51.                 , Space:=False, Other:=False, FieldInfo:=Array(1, 1), _
  52.                 TrailingMinusNumbers:=True
  53.             Else
  54.                 Workbooks.OpenText Filename:=Fullpath, Origin:=Windows(WorkName).ActiveSheet.Range("b2"), _
  55.                 DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, _
  56.                 ConsecutiveDelimiter:=True, Tab:=True, Semicolon:=False, Comma:=False, _
  57.                 Space:=True
  58.             End If
  59.         End If
  60.         
  61.         sheetname = Windows(WorkName).ActiveSheet.Range("b3")
  62.         
  63.         If sheetname <> "" Then
  64.             
  65.             '檢查活頁是否存在
  66.             flag = 0
  67.             For j = 1 To Windows(Filename).Parent.Sheets.Count
  68.                 If Windows(Filename).Parent.Sheets(j).Name = sheetname Then
  69.                    flag = 1
  70.                    Exit For
  71.                 End If
  72.             Next
  73.             
  74.             If flag = 1 Then
  75.                 Windows(Filename).Parent.Sheets(sheetname).Select  '切換活頁
  76.             End If
  77.                
  78.         End If
  79.         Set objsheet = Windows(Filename).ActiveSheet '切換視窗
  80.         
  81.         '選取來源範圍
  82.          objsheet.Cells.Select
  83.          'copy
  84.          Selection.Copy
  85.         
  86.         Windows(desc).Activate '切換視窗
  87.         
  88.         Sheets.Add after:=Worksheets(Worksheets.Count)  '增加活頁
  89.         ActiveSheet.Paste   '貼上
  90.         ActiveSheet.Range("A1").Select  '將選取範圍取消
  91.         

  92.         ActiveSheet.Name = strFileName     '將活頁名稱改成檔案名稱


  93.         '避免copy太多資料時,要關閉檔案時.會問記憶體的資料是否要保留
  94.         ActiveSheet.Range("A1").Copy
  95.         
  96.        '將來源檔案關閉
  97.        Windows(Filename).Close
  98.         
  99.         i = i + 1 '讀取下一個檔案名稱
  100.     Wend
  101.     MsgBox "已將所有檔案匯入活頁中", , "彰化一整天的Blog http://272586.blogspot.com"
  102. End Sub

  103. Private Sub cmdSelectFile_Click()
  104.     Dim fd As FileDialog    '宣告一個檔案對話框
  105.    
  106.     Set fd = Excel.Application.FileDialog(msoFileDialogFilePicker)  '設定選取檔案功能
  107.    
  108.    
  109.     fd.Filters.Clear    '清除之前的資料
  110.    
  111.     fd.Filters.Add "Excel File", "*.xls*" '設定顯示的副檔名
  112.     fd.Filters.Add "Word File", "*.txt"
  113.     fd.Filters.Add "Word File", "*.csv"
  114.     fd.Filters.Add "所有檔案", "*.*"
  115.    
  116.     fd.Show '顯示對話框
  117.    
  118.     str_row = Range("b1").End(xlDown).Row '開始列前一筆(最後一筆非空白資料的列數)
  119.    
  120.    
  121.    
  122.     For i = 1 To fd.SelectedItems.Count
  123.         strFullName = fd.SelectedItems(i)

  124.         
  125.         
  126.         n = rinstr(strFullName, "\")
  127.         
  128.         strFileNameType = Mid(strFullName, n + 1)
  129.         
  130.         strFullPath = Left(strFullName, n)
  131.         Sheet1.Cells(i + str_row, 1) = strFullPath '顯示所選取的檔案路徑
  132.         

  133.         n = InStr(1, strFileNameType, ".")
  134.         
  135.         strFileName = Left(strFileNameType, n - 1)
  136.         strsFileType = Mid(strFileNameType, n + 1)
  137.         
  138.         Sheet1.Cells(i + str_row, 2) = strFileNameType

  139.         
  140.     Next
  141. End Sub

  142. Function rinstr(ByVal t As String, ByVal s As String)
  143.     '自訂函數找尋某個字串最後出現的位置
  144.     Dim i As Integer
  145.     Dim n As Integer
  146.    
  147.     n = 0
  148.     For i = 1 To Len(t)
  149.         If Mid(t, i, 1) = s Then
  150.            n = i
  151.         End If
  152.     Next
  153.     rinstr = n
  154. End Function

複製代碼
回復 支持 反對

使用道具 舉報

發表於 2013-12-23 18:37:37 | 顯示全部樓層
太實用的,
謝謝分享
回復 支持 反對

使用道具 舉報

發表於 2014-1-9 11:07:41 | 顯示全部樓層
thank for your share
回復 支持 反對

使用道具 舉報

發表於 2014-1-10 23:07:41 | 顯示全部樓層
如果可以這樣的話 真的很方便耶
超省時的
回復 支持 反對

使用道具 舉報

發表於 2014-1-14 10:56:56 | 顯示全部樓層
可以選檔案位址. 這樣實在方便太多搂
回復 支持 反對

使用道具 舉報

發表於 2014-1-29 11:57:58 | 顯示全部樓層
這個時在是太方便了!!感覺VBA有點深澳,慢慢研究
回復 支持 反對

使用道具 舉報

發表於 2014-2-10 10:28:40 | 顯示全部樓層
謝謝分享,精進自已的程式能力
回復 支持 反對

使用道具 舉報

發表於 2014-2-10 14:53:07 | 顯示全部樓層
謝謝imingho大大,剛好有用到,好用
回復 支持 反對

使用道具 舉報

發表於 2014-2-23 23:44:40 | 顯示全部樓層
這實在是太實用了!!非常感謝您的分享~~
回復 支持 反對

使用道具 舉報

您需要登錄後才可以回帖 登錄 | 立即註冊

本版積分規則

 ㄚ母滴雞湯
 員林香純滴雞精

Archiver|手機版|小黑屋|彰化一整天的論壇(Excel,Office)  |网站地图

GMT+8, 2017-12-11 10:16 , Processed in 0.040331 second(s), 14 queries , Apc On.

Powered by Discuz! X3.2

© 2001-2013 Comsenz Inc.

快速回復 返回頂部 返回列表