VBA Excel 循環遍歷同目錄下的all.xslm文件

Question

下午好，

我想檢查我目錄中的所有文件。 為此，我決定遍歷所有這些。

我在這里找到的好代碼：

https://www.thespreadsheetguru.com/the-code-vault/2014/4/23/loop-through-all-excel-files-in-a-given-folder

並因此出於我的個人目的對其進行了更改。

 Sub LoopAllExcelFilesInFolder()

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

 Application.ScreenUpdating = False
 Application.EnableEvents = False
 Application.Calculation = xlCalculationManual

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 = "*.xlsm*"

 '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

'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

但看起來該代碼僅適用於第一個文件。

我不僅有這個問題，因為我在這里發現了類似的問題：

VBA 循環瀏覽文件夾中的 excel 工作簿並復制數據 - 不循環瀏覽所有文件

Excel-VBA 循環不遍歷文件夾中的所有文件

有沒有辦法讓這段代碼適用於所有文件而不是一個文件？

還是我應該使用更好For Each而不是Do While?

我的問題與這個問題非常相似：

循環訪問 workbook.close 上的文件時代碼停止

根本不提示新文件。 在我的 VBA 控制台中是“未選擇項目”

Answer 1

我似乎有相同的代碼，它工作正常。

當我在某處拾取一些代碼時，我傾向於逐步進行小的更改，並確保我所做的每一個更改都能正常工作。

 Sub LoopThroughFilesvieux()

        Dim xFd As FileDialog
        Dim xFdItem As Variant
        Dim xFileName As String
        Dim xWB As Workbook

        Set xFd = Application.FileDialog(msoFileDialogFolderPicker)
        If xFd.Show = -1 Then

        xFdItem = xFd.SelectedItems(1) & Application.PathSeparator
        xFileName = Dir(xFdItem & "*.xls*")

        On Error Resume Next
        Do While xFileName <> ""

          Set xWB = Workbooks.Open(xFdItem & xFileName)
          With xWB

'yourcode

          End With
    xWB.Close
    xFileName = Dir
    Loop
    End If
    End Sub

您可能可以從我的結構或您從中獲取的原始結構重新開始，並一點一點地添加您的代碼行，也可以嘗試逐步運行它以查看它的退出位置。