VBA for renaming multiple excel files in a folder according to a specific Cell value?

[smfismfi]

I want a VBA for renaming multiple excel files in a folder according to a specific Cell value in that excel file? Is it possible? if yes then kindly provide VBA code

 

[smfismfi]

Please reply urgent

 

[wideboydixon]

This will achieve the requirement but you didn't specify how it should work. You'll need to adapt to your needs:

Sub RenameFilesInFolder()

Dim folderPath As String
Dim filePath As String
Dim newFileName As String
Dim fileNames As String
Dim fileCount As Long
Dim fso As Object

Set fso = CreateObject("Scripting.FileSystemObject")

folderPath = "C:\SomePath\" ' <-- Change this as appropriate
newFileName = Range("A1").Value ' <-- Change the range as appropriate

fileCount = 0
filePath = Dir$(folderPath & "*.*")
Do While filePath <> ""
    fileCount = fileCount + 1
    fileNames = fileNames & filePath & "," & newFileName & CStr(fileCount) & "." & fso.GetExtensionName(filePath) & ","
    filePath = Dir$
Loop

Dim renameFiles() As String

renameFiles = Split(fileNames, ",")

For fileCount = 0 To UBound(renameFiles) - 2 Step 2
    Name folderPath & renameFiles(fileCount) As folderPath & renameFiles(fileCount + 1)
Next

End Sub

WBD

 

[smfismfi]

Sorry my bad. Here is complete details:

Basically I have 400 excel files kept in a folder and each file contains two sheets in it. Each file has an unspecified file name and i want to rename all of 400 excel files as per a value in cell No. B2 of sheet 2 of each excel file. Further i want to not to define the path so that each time i can put a different path at the start of running of macro.

 

[wideboydixon]

Sub RenameFilesInFolder()

Dim folderBrowser As Object
Dim folderPath As String
Dim filePath As String
Dim newFileName As String
Dim fso As Object
Dim wb As Workbook

Set folderBrowser = CreateObject("Shell.Application").BrowseForFolder(0, "", 0)
If folderBrowser Is Nothing Then Exit Sub

Set fso = CreateObject("Scripting.FileSystemObject")

folderPath = folderBrowser.Self.Path & "\"

Application.ScreenUpdating = False
filePath = Dir$(folderPath & "*.xls*")
Do While filePath <> ""
    Set wb = Workbooks.Open(folderPath & filePath)
    If wb.Sheets.Count > 1 Then
        newFileName = wb.Sheets(2).Range("B2").Value
    Else
        newFileName = ""
    End If
    wb.Close False
    If newFileName <> "" Then
        Name folderPath & filePath As folderPath & newFileName & "." & fso.GetExtensionName(filePath)
    End If
    filePath = Dir$
Loop
Application.ScreenUpdating = True

End Sub

WBD