[發問] 請教開啟檔案之檔名如何依序貼到分頁

kevin650827

目前巨集已可以將所要開的資料夾內檔案開啟選擇所需的range並貼上新增的分頁 ,但欲加上開啟的檔名要加到 框選的range 前面一欄. 怎麼測試都用不出來....
請教各位先賢, 如何利用迴圈或者那一種寫法可以達到此目的. 煩請指教.謝謝
     

        Workbooks("Get_report.xlsm").Activate  '確認巨集檔案是正在執行中
        Sheets("Address").Select
        
        For i = 2 To 65536
        
                          Sheets("Address").Select
                          Sheets("Address").Activate
                        
                          If Cells(i, 1).Value = "" Then Exit For
                          ToolID = Cells(i, 1).Value
                    
                          '確認檔案是否存在
                          sPath$ = "D:\temp\Lot_Report\" & ToolID
                          sDir$ = Dir(sPath, vbDirectory)
                          If sDir = "" Then MsgBox " Path " & sDir & " Not Found"
                          sDir$ = Dir(sPath & "\*.*")
                              
                    
                         '新增機台頁次
                         ActiveWorkbook.Sheets.Add After:=Worksheets(Worksheets.Count)
                         ActiveSheet.Name = ToolID
                 
               
                Do Until sDir = ""
                     
                          '開檔路徑
                          Workbooks.OpenText fileName:="D:\temp\Lot_Report\" & ToolID & "\" & sDir, Origin:=xlWindows _
                          , StartRow:=1, DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, _
                          Tab:=False, Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar:="|", FieldInfo:=Array(1, 1), TrailingMinusNumbers:=True
                          
                                                   
                          '搜尋關鍵字
                          Cells.Find(What:="DYNAMIC ", After:=ActiveCell, LookIn:=xlFormulas, lookat:= _
                           xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
                          , MatchByte:=False, SearchFormat:=False).Activate
                              
                          '選擇需要的資料並複製到機台頁面
                          ActiveCell.Range("A1:J29").Select
                          Selection.Copy
                          Workbooks("Get_report.xlsm").Activate
                          Sheets(ToolID).Select
                          Sheets(ToolID).Activate
                                                                           
                          EndRow = ActiveSheet.UsedRange.Rows.Count + 1 '所有使用中的列數+1
                          Rows(EndRow).PasteSpecial Paste:=xlPasteValues '目前使用中的分頁,的最下方空白列貼上值

                          Application.DisplayAlerts = False
                          Workbooks(sDir).Close  '關閉另存新檔的檔案
                          sDir = Dir() '讀取下一個檔案
                        
                  
                Loop
               
                            Sheets(ToolID).Select
                            Sheets(ToolID).Activate
                            Range("A1").Select
               
               
   
        Next

stillfish00

回復 1# kevin650827
試試看:
Rows(EndRow).PasteSpecial Paste:=xlPasteValues
改為
Range("A" & EndRow).Value = sDir
Range("B" & EndRow).PasteSpecial Paste:=xlPasteValues


程式碼可再優化:
1. 減少Select/Activate
2. 要考慮Find沒找到時該如何處理