Excel VBA - Loop through files and make changes to names and file type

[RCBricker]

So I am trying to loop through all the files in a folder and make either changes to the extension, the name or both. I have code (see below) and the problem is that it is only looping through files with extension ".xslx". I need to make changes to the names of all ".pdf". I need to make changes to the names of all ".xlsx". And finally, I need to make changes to the names of all "xls*" as well and change them all into ".xlsx". Preferably with out opening any of them. I want to avoid opening any files due to bandwidth issues (Net is soooooooooo slow here).

Sub LOOPCHANGE()

Dim wb As Workbook
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim FldrPicker As FileDialog
Dim strOLDP As String, strOLDN As String, strNEWP As String, strNEWN As String, strEXT As String


  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


NextCode:
  myPath = myPath
  If myPath = "" Then GoTo ResetSettings

  myFile = Dir(myPath)

  Do While myFile <> ""

        strEXT = Right(myFile, Len(myFile) - InStrRev(myFile, "."))
        
        strOLDP = myPath
        strOLDN = myFile
        strNEWN = Mid(myFile, InStrRev(myFile, "\") + 1, InStrRev(myFile, ".") - InStrRev(myFile, "\") - 1)
        
Debug.Print strEXT
Debug.Print strOLDN
        
        If Not UCase(Right(strEXT, 1)) = "F" Then
        strEXT = ".xlsx"
        End If
        
        strNEWN = strNEWN & strEXT
        
        strNEWP = myPath
        strNEWN = myFile
        
        Name strOLDP & strOLDN As strNEWP & strNEWN

      myFile = Dir
  Loop

  MsgBox "Task Complete!"

ResetSettings:

    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True

End Sub

any help is greatly appreciated.

thanks,

rich

 

[Macropod]

Changing file extensions does not change the file type! Not only that, changing the extensions may render the files unusable until their returned to their original values. If you need to change a file type, the file needs to be opened and re-saved in the appropriate format.

 

[RCBricker]

That is good to know. I will have to change my process then. hmmm

 

[RCBricker]

ok I solved this (see code below). I am certain someone can put together something cleaner.

Sub LOOPCHANGE()

Dim wb As Workbook, wb1 As Workbook, wb2 As Workbook, wbTHIS As Workbook
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim FldrPicker As FileDialog
Dim strOLDP As String, strOLDN As String, strNEWP As String, strNEWN As String, strEXT As String, strQ As String, strMON As String, str As String
Dim i As Variant

    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .Calculation = xlCalculationManual
        .DisplayAlerts = False
    End With
    Set wbTHIS = ThisWorkbook
    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
    
    
NextCode:
    myPath = myPath
    If myPath = "" Then GoTo ResetSettings
    
    myFile = Dir(myPath)
    
    Do While myFile <> ""
        strNEWN = Mid(myFile, InStrRev(myFile, "\") + 1, InStrRev(myFile, ".") - InStrRev(myFile, "\") - 1) 'file name no extension
        If Right(strNEWN, 10) = "-DDRS-DDRS" Then
            strNEWN = Replace(strNEWN, "-DDRS-DDRS", "-DDRS")
        End If
        If Not Left(myFile, 2) = "18" Then
            strNEWN = Mid(myFile, InStrRev(myFile, "\") + 1, InStrRev(myFile, ".") - InStrRev(myFile, "\") - 1) 'file name no extension
            strEXT = Right(myFile, Len(myFile) - InStrRev(myFile, ".")) 'extension only
            strOLDP = myPath    'path
            strOLDN = myFile    'file name and extension
            If Mid(strNEWN, 12, 1) = "." Then
                strNEWN = Replace(strNEWN, Mid(strNEWN, 12, 1), " ")
            End If
            If Left(myFile, 4) = "2018" Then
                strMON = Mid(strNEWN, 5, 2)
                Select Case strMON
                    Case "01", "02", "03"
                        strQ = "01"
                    Case "04", "05", "06"
                        strQ = "02"
                    Case "07", "08", "09"
                        strQ = "03"
                    Case "10", "11", "12"
                        strQ = "04"
                End Select
                strNEWN = Replace(strNEWN, "201801 ", "18-" & strQ & "-" & strMON & "-")
            Else
                If Mid(strNEWN, 3, 3) = "201" Then
                    strMON = Left(strNEWN, 2)
                    str = Mid(strNEWN, 3, 4)
                    Select Case strMON
                        Case "01", "1"
                            strQ = "02"
                            strMON = "04"
                        Case "02", "2"
                            strQ = "02"
                            strMON = "05"
                        Case "03", "3"
                            strQ = "02"
                            strMON = "06"
                        Case "04", "4"
                            strQ = "03"
                            strMON = "07"
                        Case "05", "5"
                            strQ = "03"
                            strMON = "08"
                        Case "06", "6"
                            strQ = "03"
                            strMON = "09"
                        Case "07", "7"
                            strQ = "04"
                            strMON = "10"
                        Case "08", "8"
                            strQ = "04"
                            strMON = "11"
                        Case "09", "9"
                            strQ = "04"
                            strMON = "12"
                        Case "10"
                            strQ = "01"
                            strMON = "01"
                        Case "11"
                            strQ = "01"
                            strMON = "02"
                        Case "12"
                            strQ = "01"
                            strMON = "03"
                    End Select
                    strNEWN = Replace(strNEWN, strMON & str & " ", "18-" & strQ & "-" & strMON & "-")
                End If
                If UCase(Right(strNEWN, 2)) = "BB" Then
                    strNEWN = Replace(strNEWN, "BB", "OBIEE BB")
                Else
                    If UCase(Right(strNEWN, 3)) = "ITD" Then
                        strNEWN = Replace(strNEWN, "ITD", "OBIEE ITD")
                    Else
                        If UCase(Right(strNEWN, 3)) = "YTD" Then
                            strNEWN = Replace(strNEWN, "YDT", "OBIEE YDT")
                        End If
                    End If
                End If
            End If
                
            strNEWN = strNEWN & "-DDRS" & "." & strEXT
            
            Name strOLDP & strOLDN As strOLDP & strNEWN
            If Not UCase(strEXT) = "PDF" And Not UCase(strEXT) = "XLSX" Then
                Set wb1 = Workbooks.Open(strOLDP & strNEWN)
                'Set wb1 = ActiveWorkbook
                str = wb1.FullName
                'save as xlsx
                wb1.SaveAs str & "x", FileFormat:=51
                'delete .xls file
                Kill str
            End If
        End If
        myFile = Dir
    Loop
    
    MsgBox "Task Complete!"

ResetSettings:

    With Application
        .EnableEvents = True
        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True
        .DisplayAlerts = True
    End With

End Sub