Giving names to Windows7 files according to a list in excel

[Topher]

Is there a way that I can rename a lot of files in a snap?

Like if I had a list of 300 file names that I would like to apply to 300 templates in a folder...

It would be even nicer if I could apply another column to another file detail... say "subject", "year", "category", or "details", etc.
But the Filename is first and foremost...

I want to be able to do it every once and while, because I know live updating would increase difficulty, and probably performance and is just not necessary.

 

[BrianB]

Here is some code

'=============================================================================================
'- BULK RENAME FILES IN A FOLDER
'=============================================================================================
'- METHOD
'- 1. GET_FILES MACRO  : GETS FILE NAMES FROM SELECTED FOLDER INTO WORKSHEET COLUMN A
'- 2. MANUAL           : PUT NEW NAMES INTO WORKSHEET COLUMN B
'- 3. SAVE_FILES MACRO : COPIES FILE WITH NEW NAME TO SELECTED FOLDER. DELETES THE OLD FILE
'-    If there is no new name in column B there is no action.
'- Brian Baulsom June 2006
'=============================================================================================
Const FromFolder As String = "F:\TEST\"
Const ToFolder As String = "F:\TEST\"
'---------------------------------------------------------------------------------------------
Dim ws As Worksheet
Dim MyRow As Long
Dim LastRow As Long
Dim FromFile As String
Dim ToFile As String
'=============================================================================================
'- GET FILE NAMES TO WORKSHEET
'=============================================================================================
Sub GET_FILES()
    '-----------------------------------------------------------------------------------------
    Set ws = ActiveSheet
    With ws
        .Range("A:B").Cells.ClearContents
        .Range("A1:B1").Value = Array("FROM", "TO")
        .Range("A2:B2").Value = Array(FromFolder, ToFolder)
        MyRow = 3
    End With
    '----------------------------------------------------------------------------------------
    '- GET FILE NAMES
    FromFile = Dir(FromFolder & "*.*")
    Do While FromFile <> ""
        ws.Cells(MyRow, "A").Value = FromFile
        MyRow = MyRow + 1
        FromFile = Dir
    Loop
    '----------------------------------------------------------------------------------------
    MsgBox ("Done")
End Sub
'============================================================================================
 
'=============================================================================================
'- RENAME FILES
'=============================================================================================
Sub RENAME_FILES()
    '-----------------------------------------------------------------------------------------
    rsp = MsgBox("About to rename files. OK to proceed ?", vbOKCancel)
    If rsp = vbCancel Then Exit Sub
    '-----------------------------------------------------------------------------------------
    Set ws = ActiveSheet
    LastRow = ws.Range("A65536").End(xlUp).Row
    For MyRow = 3 To LastRow
        Application.StatusBar = MyRow & "\" & LastRow
        With ws
            If .Cells(MyRow, "B").Value <> "" Then
                FromFile = FromFolder & .Cells(MyRow, "A").Value
                ToFile = ToFolder & .Cells(MyRow, "B").Value
                FileCopy FromFile, ToFile
                Kill FromFile
            End If
        End With
    Next
    '-----------------------------------------------------------------------------------------
    MsgBox ("Done")
    Application.StatusBar = False
End Sub
'=============================================================================================