excelファイルのファイル拡張子を変更するディレクトリ内のすべてのフォルダを調べる方法は？

Question

多くの.xlsファイルが異なるフォルダにあります。これらを.xlsxファイル拡張子に変換したいと思います。フォルダファイルの場所を指定するとコードがうまく動作しますが、ディレクトリ内のすべてのフォルダを表示し、.xlsファイルを.xlsxに一度に変換するように変更したいと思います。私はちょっと立ち往生している。ここに私のコードは次のとおりです。

Dim strCurrentFileExt As String 
    Dim strNewFileExt  As String 
    Dim objFSO    As Object 
    Dim objFolder   As Object 
    Dim objFile    As Object 
    Dim xlFile    As Workbook 
    Dim strNewName   As String 
    Dim strFolderPath  As String 

    strCurrentFileExt = ".xls" 
    strNewFileExt = ".xlsx" 

    strFolderPath = "C:\myExcelFolders" 
    If Right(strFolderPath, 1) <> "\" Then 
     strFolderPath = strFolderPath & "\" 
    End If 

    Set objFSO = CreateObject("Scripting.FileSystemObject") 
    Set objFolder = objFSO.getfolder(strFolderPath) 
    For Each objFile In objFolder.Files 
     strNewName = objFile.Name 
     If Right(strNewName, Len(strCurrentFileExt)) = strCurrentFileExt Then 
      Set xlFile = Workbooks.Open(objFile.Path, , True) 
      strNewName = Replace(strNewName, strCurrentFileExt, strNewFileExt) 
      Application.DisplayAlerts = False 
      Select Case strNewFileExt 
      Case ".xlsx" 
       xlFile.SaveAs strFolderPath & strNewName, XlFileFormat.xlOpenXMLWorkbook 
      Case ".xlsm" 
       xlFile.SaveAs strFolderPath & strNewName, XlFileFormat.xlOpenXMLWorkbookMacroEnabled 
      End Select 
      xlFile.Close 
      Application.DisplayAlerts = True 
     End If 
    Next objFile 

Answer 1

リファレンス本（フォルダ内の各サブフォルダのために）：

Loop Through All Subfolders Using VBA

Dim strCurrentFileExt As String 
Dim strNewFileExt  As String 
Dim objFSO    As Object 
Dim objFolder   As Object 
Dim objFile    As Object 
Dim xlFile    As Workbook 
Dim strNewName   As String 
Dim strFolderPath  As String 

strCurrentFileExt = ".xls" 
strNewFileExt = ".xlsx" 

strFolderPath = "C:\myExcelFolders" 
If Right(strFolderPath, 1) <> "\" Then 
    strFolderPath = strFolderPath & "\" 
End If 

Set objFSO = CreateObject("Scripting.FileSystemObject") 
Set objFolder = objFSO.getfolder(strFolderPath) 
For Each SubFolder In objFolder.SubFolders 
    For Each objFile In objFolder.Files 
    strNewName = objFile.Name 
    If Right(strNewName, Len(strCurrentFileExt)) = strCurrentFileExt Then 
     Set xlFile = Workbooks.Open(objFile.Path, , True) 
     strNewName = Replace(strNewName, strCurrentFileExt, strNewFileExt) 
     Application.DisplayAlerts = False 
     Select Case strNewFileExt 
     Case ".xlsx" 
      xlFile.SaveAs strFolderPath & strNewName, XlFileFormat.xlOpenXMLWorkbook 
     Case ".xlsm" 
      xlFile.SaveAs strFolderPath & strNewName, XlFileFormat.xlOpenXMLWorkbookMacroEnabled 
     End Select 
     xlFile.Close 
     Application.DisplayAlerts = True 
    End If 
    Next objFile 
Next 

EDIT

あなたは無限のサブフォルダにドリルダウンしたい場合は、再発する必要があります：

Function test(sPath As String) As String 

    Dim strCurrentFileExt As String 
    Dim strNewFileExt  As String 
    Dim objFSO    As Object 
    Dim objFolder   As Object 
    Dim objFile    As Object 
    Dim xlFile    As Workbook 
    Dim strNewName   As String 

    strCurrentFileExt = ".xls" 
    strNewFileExt = ".xlsx" 

    If Right(sPath, 1) <> "\" Then 
     sPath = sPath & "\" 
    End If 

    Set objFSO = CreateObject("Scripting.FileSystemObject") 
    Set objFolder = objFSO.getfolder(sPath) 
    For Each SubFolder In objFolder.SubFolders 
     For Each objFile In objFolder.Files 
     strNewName = objFile.Name 
     If Right(strNewName, Len(strCurrentFileExt)) = strCurrentFileExt Then 
      Set xlFile = Workbooks.Open(objFile.Path, , True) 
      strNewName = Replace(strNewName, strCurrentFileExt, strNewFileExt) 
      Application.DisplayAlerts = False 
      Select Case strNewFileExt 
      Case ".xlsx" 
       xlFile.SaveAs sPath & strNewName, XlFileFormat.xlOpenXMLWorkbook 
      Case ".xlsm" 
       xlFile.SaveAs sPath & strNewName, XlFileFormat.xlOpenXMLWorkbookMacroEnabled 
      End Select 
      xlFile.Close 
      Application.DisplayAlerts = True 
     End If 
     Next objFile 
     test = test(SubFolder.Path) 
    Next 

End Function 

Sub TestR() 

    Call test("C:\myExcelFolders") 

End Sub