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
LinkBack URL
About LinkBacks
In your greatness, remain humble! 
Register To Reply
below the post.
Originally Posted by Leith Ross
Bookmarks