• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

Renaming all files in a folder as per cell contents [SOLVED]

Hi All,


I have a set of files in a few folders. Each folder signifies a different department. The files are downloaded from the company portal and are named as per the date and time. Each workbook has just one worksheet and the intended name of the each workbook is cell B2 of that respective workbook.
What I need is a macro which will first ask me for the folder containing the files, then open each workbook, copy the cell contents of cell B2, rename the workbook with that name (from cell B2) and close the file, till the last file. Right now I do this manually. The downloading of the workbooks itself is time consuming and add to that this process of renaming the files takes up a lot of time.

Any help will be appreciated.
 
Pls check with this..

Code:
Sub GetDataFromAllFilesInaFolder()
 'Set a reference to Microsoft Scripting Runtime by using
    'Tools > References in the Visual Basic Editor (Alt+F11)
Dim objFile As Scripting.File
Dim objFolder As Scripting.Folder
Dim owbk As Workbook, twbk As Worksheet, ws As Worksheet
Dim cRow As Integer, fName As String, fol As String
Dim v As String, fv As String

With Application.FileDialog(msoFileDialogFolderPicker)
      .AllowMultiSelect = False
      .Show
      On Error Resume Next
      fol = .SelectedItems(1)
      Err.Clear
      On Error GoTo 0
    End With
    If fol = "" Then Exit Sub
   
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder(fol)

For Each objFile In objFolder.Files
    Set twbk = ThisWorkbook.Sheets("Sheet1")
    cRow = twbk.Range("A" & Rows.Count).End(xlUp).Row
            Set owbk = Workbooks.Open(objFile)
                Set ws = owbk.Sheets(1)
                    v = ws.[B2].Value
                        twbk.Range("A" & cRow + 1).Value = v 'Change as need
                fv = v & ".xlsx"
                fName = objFolder & "\" & fv
                ws.SaveAs Filename:=fName, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
                Windows(fv).Close False
            Kill objFile
Next objFile

Set ws = Nothing
Set owbk = Nothing
Set twbk = Nothing
Set objFolder = Nothing
Set objFSO = Nothing
End Sub
 
Back
Top