Renaming WAV Files in a Folder

Hello spiwere,

I have made a few changes to the code . This should work for now. Here is the updated code and workbook.

Macro Version 2

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     ' Points to My Documents folder.
    
        FileType = ".wav"
        
      ' This can be a Shell special folder constant or a folder path.
        ParentFolder = "C:\Users\ABC\Desktop\Renaming\Spi"
        
        SubFolder = "New Folder"
        
        Set Wks = ActiveSheet
        
        Set Rng = Wks.Range("B2:E2")
        
          ' 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 unique Ids for the these files.
                Set colFiles = New Collection
                
                    For Each Item In Files
                      ' Unique Id is before first space in the file name.
                        colFiles.Add True, Left(Item.Name, InStr(1, Item.Name, " ") - 1)
                    Next Item
                    
                  ' Only copy and rename files on the worksheet if the file's unique Id is 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