使用VBA通过工作簿文件夹循环访问代码？

我有一个具有相同格式的excel文件的文件夹。 我修改了下面的代码来确定date并重新格式化，其中“i”根据第2列的最后一行确定范围中的单元格数量。

Sub Test() Dim i As Long i = Sheet1.Cells(Rows.Count, 2).End(xlUp).Row With Range("K3:K" & i) .Formula = "=DATE(A3,G3,H3)" .NumberFormat = "ddmmmyyyy" End With End Sub 

我想在我的文件夹中的所有工作簿上执行此代码。 我已经find了以下问题在计算器上：

循环遍历指定文件夹中所有excel文件的代码，以及从特定单元格中提取数据的代码

它并没有遍历我的所有文件，只对我打开的第一个excel文件有效。 如何通过文件夹中的所有工作簿循环此代码？ 以下是我到目前为止。

 Sub Test() Dim lCount As Long Dim wbResults As Workbook Dim wbCodeBook As Workbook Dim i As Long Application.ScreenUpdating = False Application.DisplayAlerts = False Application.EnableEvents = False On Error Resume Next Set wbCodeBook = ThisWorkbook With Application.FileSearch .NewSearch .LookIn = "C:\Test" .FileType = msoFileTypeExcelWorkbooks If .Execute > 0 Then For lCount = 1 To .FoundFiles.Count Set wbResults = Workbooks.Open(Filename:=.FoundFiles(lCount), UpdateLinks:=0) i = wbResults.Worksheets("Sheet1").Cells(wbResults.Worksheets("Sheet1").Rows.Count, 2).End(xlUp).Row With wbResults.Worksheets("Sheet1").Range("K3:K" & i) .Formula = "=DATE(A3,G3,H3)" .NumberFormat = "ddmmmyyyy" End With 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

Excel 2007及更高版本不支持Application.FileSearch 。 试试这个代码（ 循环浏览文件夹中的文件的代码来自@ mehow的网站 ）

 Sub PrintFilesNames() Dim file As String Dim wbResults As Workbook Dim i As Long Dim myPath As String Application.ScreenUpdating = False Application.DisplayAlerts = False myPath = "D:\" ' note, path ends with back slash file = Dir$(myPath & "*.xls*") While (Len(file) > 0) Set wbResults = Workbooks.Open(Filename:=myPath & file, UpdateLinks:=0) With wbResults.Worksheets(Split(file, ".")(0)) i = .Cells(.Rows.Count, 2).End(xlUp).Row With .Range("K3:K" & i) .Formula = "=DATE(A3,G3,H3)" .NumberFormat = "ddmmmyyyy" End With End With wbResults.Close SaveChanges:=True 'get next file file = Dir Wend Application.DisplayAlerts = True Application.ScreenUpdating = True End Sub