Renaming WAV Files in a Folder

Hello spiwere,

The attached workbook has the macro below added to it along with a button on the worksheet to run it. You did not say what the parent folder was. The default parent folder location is "My Documents". The user can select a different folder when the macro is run.

Option Explicit

Sub CopyAndRenameFiles()

  ' Thread:  http://www.excelforum.com/excel-programming-vba-macros/1016265-renaming-wav-files-in-a-folder.html
  
    Dim colFiles     As Collection
    Dim EndRow       As Long
    Dim fc           As Long
    Dim Files        As Object
    Dim FileType     As String
    Dim Item         As Variant
    Dim NewName      As String
    Dim oFolder      As Object
    Dim oShell       As Object
    Dim ParentFolder As Variant
    Dim r            As Long
    Dim Rng          As Range
    Dim SubFolder    As Variant
    Dim Title        As String
    Dim Wks          As Worksheet
    
    Const ssfPersonal As Long = 5
    
        FileType = ".wav"
        
        ParentFolder = ssfPersonal  ' Constant points to My Documents. This can also be a string like "C:\Users\Owner"
        
        SubFolder = "New Folder"
        
        Set Wks = ActiveSheet
        
        Set Rng = Wks.Range("A2:F2")
        
          ' Find the last row with data.
            EndRow = Wks.Cells.Find("*", , xlFormulas, xlWhole, xlByRows, xlPrevious, False, False, False).Row
            If EndRow < Rng.Row Then Exit Sub
        
            Set Rng = Rng.Resize(RowSize:=EndRow - Rng.Row + 1)
            
                Set oShell = CreateObject("Shell.Application")
                
                On Error Resume Next
                    ParentFolder = oShell.Namespace(ParentFolder).Self.Path
                    If Err <> 0 Then
                        MsgBox "The folder '" & ParentFolder & " was Not Found.", vbCritical
                        Exit Sub
                    End If
                On Error Resume Next
                
              ' Let the User choose a different folder if needed.
                Title = "The Defauilt Parent Directory is ...   " & ParentFolder & vbCrLf
                Title = Title & "You may choose a different folder if needed." & vbCrLf & "Click Cancel to use the Default Folder."
                Set oFolder = oShell.BrowseForFolder(0, Title, &H271)
                
                If Not oFolder Is Nothing Then ParentFolder = oFolder.Self.Path
                        
              ' Add characters if needed for proper syntax.
                ParentFolder = IIf(Right(ParentFolder, 1) <> "\", ParentFolder & "\", ParentFolder)
                SubFolder = ParentFolder & IIf(Right(SubFolder, 1) <> "\", SubFolder & "\", SubFolder)
                FileType = IIf(Left(FileType, 1) <> ".", "." & FileType, FileType)
                
              ' Create the Subfolder if it does not exist.
                If oShell.Namespace(SubFolder) Is Nothing Then MkDir SubFolder
        
              ' Create a List only the files of the given file type.
                Set Files = oFolder.Items
                
                Files.Filter 64, "*" & FileType
                
              ' Create a collection of the these files for validation.
                Set colFiles = New Collection
                
                    For Each Item In Files
                        colFiles.Add True, Item.Name
                    Next Item
                    
                  ' Only copy and rename files on the worksheet if found in the Collection.
                    For Each Item In Rng.Columns(1).Cells
                        r = r + 1
                        On Error Resume Next
                            If colFiles(Item.Value) Then
                                If Err = 0 Then
                                    NewName = Format(Rng.Cells(r, "C"), "md")
                                    NewName = NewName & Format(Rng.Cells(r, "D"), "hhMMss")
                                    NewName = NewName & "_" & Rng.Cells(r, "E")
                                    Name ParentFolder & Item.Value As SubFolder & NewName & FileType
                                    fc = fc + 1
                                End If
                            End If
                        On Error GoTo 0
                    Next Item
                
                MsgBox fc & " Files were Renamed and Copied to " & vbCrLf & SubFolder & ".", vbInformation
                
End Sub