循环遍历文件夹中的工作簿以将单元格复制并插入到主工作簿中

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