循環遍歷文件夾中的工作簿以將單元格複製並插入到主工作簿中

Question

我必須通過工作簿中的短語「BATCH」開頭的文件夾複製並將複製的單元格插入主工作簿中的一個工作表。 我試過使用我在網上找到的一個例子，但它不工作。它什麼都不做。

Sub RunCodeOnAllXLSFiles() 
Dim lCount As Long 
Dim wbResults As Workbook 
Dim wbCodeBook As Workbook 


Application.ScreenUpdating = False 
Application.DisplayAlerts = False 
Application.EnableEvents = False 

On Error Resume Next 
Set wbCodeBook = ThisWorkbook 
With Application.FileSearch 
.NewSearch 
.LookIn = "C:\Path" 
.FileType = msoFileTypeExcelWorkbooks 
.Filename = "BATCH*.xls" 
If .Execute > 0 Then 
For lCount = 1 To .FoundFiles.Count 
Set wbResults = Workbooks.Open(Filename:=.FoundFiles(lCount), UpdateLinks:=0) 

Workbooks(Filename).Worksheets("Data").Range("B23:Z38").Copy 
ThisWorkbook.Worksheets("Sheet1").Range("B2").Rows("1:16").Insert Shift:=xlDown 

wbResults.Close SaveChanges:=False 
Next lCount 
End If 
End With 
On Error GoTo 0 
Application.ScreenUpdating = True 
Application.DisplayAlerts = True 
Application.EnableEvents = True 
End Sub 

我還希望能夠有一個文件可以放入任何文件夾來執行此任務。

Answer 1

由於Andy G在他的評論中指出，你忘了粘貼。你的折軸768,16是

Workbooks(Filename).Worksheets("Data").Range("B23:Z38").Copy 
ThisWorkbook.Worksheets("Sheet1").Range("B2").Rows("1:16").Insert Shift:=xlDown 
ThisWorkbook.Worksheets("Sheet1").Range("B2").Paste 

編輯：自Application.FileSearchis gone as of Excel 2007，你可以使用VBA的Dir()功能嘗試這種替代方法：

Sub RunCodeOnAllXLSFiles() 
    Dim wbCodeBook As Workbook 
    Dim myPath As String 
    Dim myMask As String 
    Dim fnResults As String 
    Dim wbResults As Workbook 

    Application.ScreenUpdating = False 
    Application.DisplayAlerts = False 
    Application.EnableEvents = False 

    Set wbCodeBook = ThisWorkbook 
    myPath = "C:\Path" 
    myMask = "BATCH*.xls" 

    fnResults = Dir(myPath & "\" & myMask) 'Get 1st match 
    Do While fnResults <> "" 
     Set wbResults = Workbooks.Open(myPath & "\" & fnResults, 0) 
     Workbooks(fnResults).Worksheets("Data").Range("B23:Z38").Copy 
     ThisWorkbook.Worksheets("Sheet1").Range("B2").Rows("1:16").Insert Shift:=xlDown 
     ThisWorkbook.Worksheets("Sheet1").Range("B2").Paste 
     fnResults = Dir 'Get next match 
    Loop 

    Application.ScreenUpdating = True 
    Application.DisplayAlerts = True 
    Application.EnableEvents = True 
End Sub