[發問] 開啟中的工作簿合併至另一工作簿中

hsiaohsien

這是我錄下的巨集，每月有30天的檔案，我想在全部開啟的情形下，使用這樣的巨集將特定的工作表分別複製到合併.xls成為單一檔案，有30個工作表中
Sub Macro1()
'
' Macro1 Macro
' hsiaohsien 在 2011/9/19 錄製的巨集
'

'
    Windows("0919.xls").Activate
    Sheets("統計").Select
    Sheets("統計").Copy After:=Workbooks("合併.xls").Sheets(2)
    Sheets("統計").Select
    Sheets("統計").Name = "0919" '<---------工作表名稱命名以工作簿檔名
End Sub

Sub Macro2()
'
' Macro1 Macro
' hsiaohsien 在 2011/9/19 錄製的巨集
'

'
    Windows("0918.xls").Activate
    Sheets("統計").Select
    Sheets("統計").Copy After:=Workbooks("合併.xls").Sheets(3)
    Sheets("統計").Select
    Sheets("統計").Name = "0918" '<---------工作表名稱命名以工作簿檔名
End Sub

GBKEE

回復 1# hsiaohsien

1. Sub Ex()
   
2.     Dim Wb As Workbook
   
3.     For Each Wb In Workbooks
   
4.         If Wb.Name <> "合併.xls" Then   '排除 "合併.xls"
   
5.             Wb.Sheets("統計").Copy After:=Workbooks("合併.xls").Sheets(2)
   
6.             ActiveSheet.Name = Replace(Wb.Name, ".xls", "")
   
7.         End If
   
8.     Next
   
9.     Workbooks("合併.xls").Activate
   
10. End Sub

複製代碼

waterful.tw

Dear GBKEE版大，

1.我試了您的方法，但卻出現 "陣列索引超出範圍 (錯誤 9)"，程式碼如下：
Sub 統計()
   Dim Wb As Workbook
   For Each Wb In Workbooks
      If Wb.Name <> "統計.xls" Then   '排除 "統計.xls"
         Wb.Sheets("Sheet2").Copy After:=Workbooks("統計.xls").Sheets(2)   '錯誤9
            ActiveSheet.Name = Replace(Wb.Name, ".xls", "")
      End If
   Next
   Workbooks("統計.xls").Activate
End Sub
2.我另外又加了路徑，但卻出現 "型態不符合 (錯誤 13)"，程式碼如下：
Sub 統計()
   Dim MyBook, Wb As Workbook, MyPath As Long
   Set MyBook = ThisWorkbook
   MyPath = MyBook.Path & "\"                                        '型態不符
  With Workbooks.Open(MyPath & "*.xls")
      For Each Wb In Workbooks
         If Wb.Name <> "統計.xls" Then
            Wb.Sheets("Sheet2").Copy after:=MyBook.Sheets(Sheets.Count)
            ActiveSheet.Name = Replace(Wb.Name, ".xls", "")
         End If
      Next
   End With
   Workbooks("統計.xls").Activate
End Sub
3.我是要將不同檔名的檔案匯入一個excel檔內，再來作資料處理。

Hsieh

1. Sub ex()
   
2. Dim MyPath As String, fs As String, MySht As Worksheet
   
3. MyPath = ThisWorkbook.Path & "\"
   
4. fs = Dir(MyPath & "*.xls")
   
5. Do Until fs = ""
   
6. If fs <> ThisWorkbook.Name Then
   
7.    With Workbooks.Open(fs)
   
8.       Set MySht = .Sheets(2) '要複製的工作表
   
9.       MySht.Copy after:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
   
10.       ActiveSheet.Name = Replace(fs, ".xls", "")
    
11.       .Close
    
12.     End With
    
13. End If
    
14.     fs = Dir
    
15. Loop
    
16. End Sub

複製代碼

回復 3# waterful.tw

waterful.tw

謝謝Hsieh 版大，

waterful.tw

sorry回復到一半，等我用Hsieh版大的方法試試，有問題 再來麻煩囉~

GBKEE

回復 3# waterful.tw
Wb.Sheets("Sheet2").Copy After:=Workbooks("統計.xls").Sheets(2)   '錯誤9 ->沒有2 , 會有1  你用 Sheets.Count替代也行

Dim   MyPath As Long          '  -> 數字  Long (長整數)變數係以範圍從 -2,147,483,648 到 2,147,483,647 之 32 位元 (4 個位元組) 有號數字形式儲存。
Set MyBook = ThisWorkbook  
MyPath = MyBook.Path & "\"                                    '當然是型態不符
Dim MyPath As String  ->應修改維字元
'String之字元碼的範圍從 0 到 255。字元集的前 128 個字元 ( 0 到 127 ) 對應於標準的 U.S 鍵盤上的字元與符號

waterful.tw

Dear Hsieh & GBKEE版大，
我已複製您的程式，並修改MyPath的型態為String，結果現在是在with那行出現執行階段錯誤'1004'=>找不到檔案或檔名錯誤！
奇怪的是，"C:\Documents and Settings\Administrator\桌面\try and error\*.xls"不是電腦自己抓的? 檔名"*.xls"應該也沒錯阿? 感覺越來越亂了...orz

GBKEE

回復 8# waterful.tw

MyPath = ThisWorkbook.Path & "\"
fs = Dir(MyPath & "*.xls")  

請加上  ChDir  MyPath      改變目前的目錄  來修正錯誤

如目前的目錄或檔案夾在   ThisWorkbook.Path & "\"   
With Workbooks.Open(fs)   ->    開啟目前的目錄下檔案fs  所以不會有錯誤.
如目錄或檔案夾不在   ThisWorkbook.Path & "\"   
也可修正為   With Workbooks.Open(MyPath & fs)     ->如 :   d:\test\ fs
以避免 目前的目錄或檔案夾不是在  ThisWorkbook.Path   ->   With Workbooks.Open(fs) 會產生錯誤

可用 MsgBox  CurDir  查看目前的目錄或檔案夾
CurDir函數  ->傳回一個 Variant (String)，用來代表目前的路徑。
Excel 開啟時會依 如圖設立目前的目錄或檔案夾

下載 (60.48 KB)

2011-10-3 16:28

waterful.tw

回復 9# GBKEE

    謝謝GBKEE版大，我後來發現，可能是我要合併的工作簿格式太過複雜(由.csv檔跑過巨集，在另存為.xls檔)，EXCEL記憶體負荷不了，所以才會一值跑出'1004'執行階段錯誤！後來我改為先將csv檔資料合併到excel工作頁，在用巨集做資料處理，就OK了！不過還是謝謝版大，讓我又學到一招了！