CODEWITHSUNDEEP
vbaexcel
pokemon_Man
pokemon_Man

Reputation: 902

How to look in all folders in directory to change file extensions of excel file?

I have many .xls excel files located in different folders. I would like to convert these to .xlsx file extensions. My code works fine if I specify the folder file location but I would like to modify it to look at all folders in the directory and convert any .xls files to .xlsx in one time. I'm sorta stuck. Here's my code:

    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

Upvotes: 0

Views: 565

Answers (1)

n8.
n8.

Reputation: 1738

Reference this (for each subfolder in folders):

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

If you want to drill down to infinite subfolders then you need to recurse:

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

Upvotes: 2

Related Questions