開啟多個檔案 複製貼上(進階執行問題).....急

iverson105

大家好，爬了很多 文   看到超級版主Hsieh 的程式分享來用,卻還是不知該怎麼完成我想要的功能
我想做的事是:
打開 "開檔貼上.xlsm"
1. 按"加入檔案"的按鈕，選擇多個檔案
2. 將選擇的檔案路逕+檔案名稱 填寫到 A欄位
3. 將 A欄位的資料打開,並自動貼在自動新增的Sheet上   ..............一直bug
目前已爬文到程式碼如下

1. Sub DATA_INPUT()
   
2. Sheets("工作表1").Activate     '''''''''為我把巨集指令放在"工作表1"
   
3. 
   
4. fds = Application.GetOpenFilename("Excel Files (*.xlsm;*.xlsx), *.xlsm;*.xlsx", , , , True)
   
5. If IsArray(fds) Then
   
6. For i = 1 To UBound(fds)
   
7.    [A2].Offset(i - 1) = fds(i)
   
8. Next
   
9. End If
   
10. 
    
11. Sheets("工作表1").Activate
    
12. 
    
13. For Each a In Range([A2], Cells(Rows.Count, 1).End(xlUp))
    
14.     [color=Yellow]With Workbooks.Open(a)[/color]..........................................................error 來源
    
15.     .Sheets.Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
    
16.     .Close 0
    
17.   End With
    
18.   Next
    
19. Sheets("工作表1").Activate
    
20. End Sub

複製代碼

麻煩版上的大神
tks

准提部林

程式碼看來沒問題,
也可正確執行~~

iverson105

回復 2# 准提部林


    Hello 版主
請教????
  我發現原來在A column要完全空白;只要有任何文字error就會產生
  求解???

下載 (49.33 KB)

2020-1-31 17:35

jackyq

on error resume next  ' 把錯誤跳過去就好了

For Each a In Range([A2], Cells(Rows.Count, 1).End(xlUp))
    With Workbooks.Open(a)
    .Sheets.Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
    .Close 0
   End With
  Next
Sheets("工作表1").Activate

on error goto 0

准提部林

回復 3# iverson105

載入檔案清單前, 應將A欄清空
Sub DATA_INPUT()
Sheets("工作表1").Activate
Range([A2], Cells(Rows.Count, 1).End(xlUp)(2)).ClearContents
續~原程式碼~~
End Sub

=========================
開啟檔案前, 先用DIR檢查是否存在~~
If Dir(A) <> "" Then   
    With Workbooks.Open(A)
         .Sheets.Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
         .Close 0
    End With
End If  


========================

iverson105

回復 4# jackyq

ok..搞定了,謝謝指教
感謝

iverson105

回復 5# 准提部林

oK,搞定了
感謝版主幫忙