使用 VBA 在工作簿文件夹中循环代码？

Question

我有一个文件夹，里面有许多格式相同的 excel 文件。我修改了以下代码来确定日期并重新格式化，其中“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

我想对我文件夹中的所有工作簿执行此代码。我在stackoverflow上发现了以下问题：

Code for looping through all excel files in a specified folder, and pulling data from specific cells

它不会循环遍历我的所有文件，仅适用于我打开的第一个 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

Application.FileSearch 不受 Excel 2007 及更高版本的支持。试试这个代码 (code for looping through files in a folder was taken from @mehow's site)

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

Answer 2

这是受到 Chris Newman 在电子表格大师上的帖子的启发
复制并粘贴整个代码块，用您要执行的特定代码替换一行“wb.Worksheets(1).Range("A1:Z1").Interior.Color = RGB(51, 98, 174)”每个工作簿。

Sub LoopAllExcelFilesInFolder()
'PURPOSE: To loop through all Excel files in a user specified folder and perform a set task on them
'SOURCE: www.TheSpreadsheetGuru.com

Dim wb As Workbook
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim FldrPicker As FileDialog

'Optimize Macro Speed
  Application.ScreenUpdating = False
  Application.EnableEvents = False
  Application.Calculation = xlCalculationManual

'Retrieve Target Folder Path From User
  Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)

    With FldrPicker
      .Title = "Select A Target Folder"
      .AllowMultiSelect = False
        If .Show <> -1 Then GoTo NextCode
        myPath = .SelectedItems(1) & "\"
    End With

'In Case of Cancel
NextCode:
  myPath = myPath
  If myPath = "" Then GoTo ResetSettings

'Target File Extension (must include wildcard "*")
  myExtension = "*.xls*"

'Target Path with Ending Extention
  myFile = Dir(myPath & myExtension)

'Loop through each Excel file in folder
  Do While myFile <> ""
    'Set variable equal to opened workbook
      Set wb = Workbooks.Open(Filename:=myPath & myFile)

    'Ensure Workbook has opened before moving on to next line of code
      DoEvents

'----------------------------------------------------------
'----------------------------------------------------------
'Here is where action code goes, what is going to be performed on each workbook
    'Change First Worksheet's Background Fill Blue
      wb.Worksheets(1).Range("A1:Z1").Interior.Color = RGB(51, 98, 174)
'----------------------------------------------------------
'----------------------------------------------------------

    'Save and Close Workbook
      wb.Close SaveChanges:=True

    'Ensure Workbook has closed before moving on to next line of code
      DoEvents

    'Get next file name
      myFile = Dir
  Loop

'Message Box when tasks are completed
  MsgBox "Task Complete!"

ResetSettings:
  'Reset Macro Optimization Settings
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True

End Sub