標題: [發問] VBA 開啟多個檔案 複製貼上 [打印本頁]

---

作者: character    時間: 2012-10-1 21:10     標題: VBA 開啟多個檔案 複製貼上

大家好，我是VBA新手，爬了很多文卻還是不知該怎麼完成我想要的功能
我想做的事是:
打開 "開檔貼上.xlsm"
1. 按"加入檔案"的按鈕，選擇多個檔案
2. 將選擇的檔案路逕+檔案名稱 填寫到 A欄位
3. 按"執行"按鈕
4. 系統幫我把每個選擇的檔案 裡面的 range(A1:C6) 貼到 開檔貼上.xlsm的Result sheet

以下是我的半成品，一直卡在執行那邊，我不知道怎麼打開每個檔案，然後複製貼上，檔案關閉，再開啟下一個檔案，直到儲存格 = <>

Sub 加入檔案()
    With Application.FileDialog(msoFileDialogOpen)
         .InitialFileName = "D:\"
         .AllowMultiSelect = True
         .Show
         For i = 1 To .SelectedItems.Count
             Cells(i, 2) = .SelectedItems(i)
         Next
    End With
End Sub

Sub 執行()
Application.ScreenUpdating = False
For i = 1 To .SelectedItems.Count
inbook = Worksheets("Filelist").Cells(i, 2).Value
Workbooks.Open Filename:=inbook
Next
End Sub

---

作者: mark15jill    時間: 2012-10-2 08:29

回復 1# character

假設  主體(VBA 程式碼所在) 為 甲   複製範圍 = a1~z99
被複製的目的 為   (a1~a10檔案)

在主體內~
soae = Range("a1").CurrentRegion.Rows.Count
if  soae <>"" then
          for sh = 1 to  soae
                range("a1","z99").copy

                openfile'開啟目的檔案
               sheets("XXXX").select  '選取要貼上的活頁簿
               [a1].paste
               activeworksheet.save
               activeworksheet.close
         next
endif

大約就是這型態

---

作者: GBKEE    時間: 2012-10-2 09:45

回復 1# character
試試看

1. Option Explicit
   
2. Dim Show_File As Object
   
3. Sub 加入檔案()
   
4.     Dim I As Integer
   
5.     Set Show_File = Application.FileDialog(msoFileDialogOpen)
   
6.     With Show_File
   
7.          .InitialFileName = "D:\*.xls"  '指定 xls檔
   
8.          .AllowMultiSelect = True
   
9.          .Show
   
10.          If .SelectedItems.Count > 0 Then
    
11.             For I = 1 To .SelectedItems.Count
    
12.              Cells(I, 2) = .SelectedItems(I)
    
13.          Next
    
14.          End If
    
15.     End With
    
16. End Sub
    
17. Sub 執行()
    
18.     Dim I As Integer, Sh As Worksheet, Rng As Range
    
19.     Set Sh = Workbooks("貼上.xlsm").Sheets(1)
    
20.     With Show_File
    
21.         If .SelectedItems.Count > 0 Then
    
22.             For I = 1 To .SelectedItems.Count
    
23.                 Set Rng = Sh.Cells(Sh.Rows.Count, "A").End(xlUp).Offset(1)  'A欄最後有資料列的下一列
    
24.                 With Workbooks.Open(.SelectedItems(I))
    
25.                     .Sheets(1).Range("A1:C6").Copy Rng
    
26.                     .Close 0
    
27.                 End With
    
28.             Next
    
29.          End If
    
30.     End With
    
31.    Sh.Parent.Save   ' 貼上.xlsm  存檔
    
32. End Sub

複製代碼

---

作者: character    時間: 2012-10-9 16:57

先跟兩位熱心的大大說聲謝謝

小弟是新手還在研究，測試過後再上來回報

再次感謝! 這真是好地方~~~

---

作者: Hsieh    時間: 2012-10-9 21:46

回復 4# character

1. Sub 加入檔案()
   
2. fds = Application.GetOpenFilename("Excel Files (*.xls;*.xlsx), *.xls;*.xlsx", , , , True)
   
3. If IsArray(fds) Then
   
4. For i = 1 To UBound(fds)
   
5.    [A1].Offset(i - 1) = fds(i)
   
6. Next
   
7. End If
   
8. End Sub
   
9. Sub 執行()
   
10. For Each a In Range([A1], Cells(Rows.Count, 1).End(xlUp))
    
11.   With Workbooks.Open(a)
    
12.      .Sheets(1).[A1:C6].Copy ThisWorkbook.Sheets("Result").Cells(Rows.Count, 1).End(xlUp).Offset(1)
    
13.      .Close 0
    
14.   End With
    
15. Next
    
16. End Sub

複製代碼

---

作者: li_hsien    時間: 2013-11-29 13:15

好好用 我剛好需要

沒想到之前就有類似的文章了

又學到了一點

---

作者: iverson105    時間: 2019-12-19 12:07

請問如何將以下執行檔改成可選取儲存在不同SHEET???
Sub 執行()
For Each a In Range([A1], Cells(Rows.Count, 1).End(xlUp))
  With Workbooks.Open(a)..............這裡的小寫a,在vba理會跳成大寫A, 有關係嗎
    .Sheets(1).[A1:C6].Copy
     ThisWorkbook.Sheets("Result").Cells(Rows.Count,1).End(xlUp).Offset(1)
     .Close 0
  End With
Next
End Sub

---

歡迎光臨 麻辣家族討論版版 (http://forum.twbts.com/)