Renaming file in VBA

mehidy1437

mehidy1437

Active Member
Joined
Nov 15, 2019
Messages
348
Office Version
  1. 365
  2. 2016
  3. 2013
Platform
  1. Windows
  2. Mobile
  3. Web
Hi I have got this code on the web & its working fine.
I just need to add a condition is, while renaming the files, if its found that the same name already exists in the folder, then it will add an additional number at the end of the new name.
Please help me with this.

VBA Code: 
Sub RenameAllFilesInaFolder()
 'Set a reference to Microsoft Scripting Runtime by using
    'Tools > References in the Visual Basic Editor (Alt+F11)
    'change the file format in below xls or xlsx
    
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
Application.ScreenUpdating = False
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.[C3].Value 'file name from cell c3
                    v = "SS_" & ws.[C3].Value 'file name withe prefix and cell c3
                        twbk.Range("A" & cRow + 1).Value = v 'Change as need
                fv = v & ".xls" 'file format see below to save option for xls and xlsx
                fName = objFolder & "\" & fv
                              
                'save option for xls
                ws.SaveAs Filename:=fName, FileFormat:=xlExcel8, CreateBackup:=False
                Windows(fv).Close False
            Kill objFile
Next objFile
Application.ScreenUpdating = True
Set ws = Nothing
Set owbk = Nothing
Set twbk = Nothing
Set objFolder = Nothing
Set objFSO = Nothing
End Sub
 

Excel Facts

Back into an answer in Excel
Use Data, What-If Analysis, Goal Seek to find the correct input cell value to reach a desired result
Sort by date Sort by votes
Try something like this....

VBA Code: 
Sub RenameAllFilesInaFolder()
 'Set a reference to Microsoft Scripting Runtime by using
    'Tools > References in the Visual Basic Editor (Alt+F11)
    'change the file format in below xls or xlsx
    
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, strFileExists As String
Dim fnum As Integer

Application.ScreenUpdating = False
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.[C3].Value 'file name from cell c3
                    v = "SS_" & ws.[C3].Value 'file name withe prefix and cell c3
                        twbk.Range("A" & cRow + 1).Value = v 'Change as need
                strFileExists = Dir(objFolder & "\" & v & ".xls")
                Do While strFileExists = ""
                    fnum = fnum + 1
                    strFileExists = Dir(objFolder & "\" & v & fnum & ".xls")
                Loop
                'save option for xls
                If fnum > 0 Then
                    fv = v & fnum & ".xls" 'file format see below to save option for xls and xlsx
                Else
                    fv = v & ".xls"
                End If
                fName = objFolder & "\" & fv
                ws.SaveAs fileName:=fName, FileFormat:=xlExcel8, CreateBackup:=False
                Windows(fv).Close False
            Kill objFile
Next objFile
Application.ScreenUpdating = True
Set ws = Nothing
Set owbk = Nothing
Set twbk = Nothing
Set objFolder = Nothing
Set objFSO = Nothing
End Sub
 
Upvote 0
Thanks for your response, it's giving below error.

Runtime error: 6
Overflow
 
Upvote 0
Now there are 2 issues.

01. Some time, its asking permission to replace the existing file name.
02. It keeps changing the file name, even after completing all the file renaming.
 
Upvote 0
Hi I'm very close to my result, just having one issue is as below, for the second file/process.

Run time error 1004, couldn't find the file........

at this line,
Set owbk = Workbooks.Open(Filename:=MyFolder & MyFile)
after first runing the code.

When I re -run the sub it did the job, but again stuck at above code with 1004 error.
Please help me with this.

VBA Code: 
Option Explicit
Sub OpenFiles()
   
    Dim MyFolder As String
    Dim MyFile As String, fName As String
    Dim MyFilePatNm As String
    Dim owbk As Workbook, ws As Worksheet
    Dim v As String, fv As String, chkFile As String
    Dim strFileName As String
    Dim strFileExists As String
    Dim fnum As Integer
   
    MyFolder = "E:\FREDDY-SHARE NEW\FW21\SC_SS\"
    MyFile = Dir(MyFolder & "*size*.xls")
   
    Do Until MyFile = ""
        'Workbooks.Open Filename:=MyFolder & "" & MyFile
        MyFilePatNm = MyFolder & MyFile
        'Set owbk = Workbooks.Open(MyFilePatNm)
        Set owbk = Workbooks.Open(Filename:=MyFolder & MyFile)
                Set ws = owbk.Sheets(1)
                 v = "SS_" & ws.[C3].Value
                 chkFile = v & ".xls"
                strFileName = MyFolder & chkFile
               strFileExists = Dir(strFileName)
                Do While strFileExists <> ""
                    fnum = fnum + 1
                    strFileExists = Dir(MyFolder & v & " " & fnum & ".xls")
                Loop
               
                If fnum > 0 Then
                    fv = v & " " & fnum & ".xls"
                Else
                    fv = v & ".xls"
                End If
                fName = MyFolder & fv
                ws.SaveAs Filename:=fName, FileFormat:=xlExcel8, CreateBackup:=False
                Windows(fv).Close False
                Kill MyFilePatNm
               
    Loop
   
End Sub
 
Upvote 0
Hi Got my solution as below.

VBA Code: 
Option Explicit
Sub RenameAllFilesInFolder()
  
    Dim MyFolder As String
    Dim MyFile As String, fName As String
    Dim MyFilePatNm As String
    Dim owbk As Workbook, ws As Worksheet
    Dim v As String, fv As String, chkFile As String
    Dim strFileName As String
    Dim strFileExists As String
    Dim fnum As Integer
  
    MyFolder = "E:\FREDDY-SHARE NEW\FW21\SC_SS\"
    MyFile = Dir(MyFolder & "*size*.xls")
      
 
    Do Until MyFile = ""
     'MyFilePatNm = Empty
        MyFilePatNm = MyFolder & MyFile
        'Workbooks.Open Filename:=MyFolder & "" & MyFile
         Set owbk = Workbooks.Open(MyFilePatNm)
        'Set owbk = Workbooks.Open(Filename:=MyFolder & MyFile)
                Set ws = owbk.Sheets(1)
                 v = "SS_" & ws.[C3].Value
                 chkFile = v & ".xls"
                strFileName = MyFolder & chkFile
               strFileExists = Dir(strFileName)
                Do While strFileExists <> ""
                    fnum = fnum + 1
                    strFileExists = Dir(MyFolder & v & " " & fnum & ".xls")
                Loop
              
                If fnum > 0 Then
                    fv = v & " " & fnum & ".xls"
                Else
                    fv = v & ".xls"
                End If
                fName = MyFolder & fv
                ws.SaveAs Filename:=fName, FileFormat:=xlExcel8, CreateBackup:=False
                Windows(fv).Close False
                Kill MyFilePatNm
        MyFile = Dir(MyFolder & "*size*.xls")
    Loop
        
End Sub
 
Upvote 0
Thank you very much, Richard U for your help.
 
Upvote 0
While running the script for more files, if it found the same name then its add increment number for the duplicate name, but then its keeping adding the increment number even for the unique name also.

What goes wrong here?
VBA Code: 
Option Explicit
Sub RenameAllFilesInFolder()

    Dim MyFolder As String
    Dim MyFile As String, fName As String
    Dim MyFilePatNm As String
    Dim owbk As Workbook, ws As Worksheet
    Dim v As String, fv As String, chkFile As String
    Dim strFileName As String
    Dim strFileExists As String
    Dim fnum As Integer

    MyFolder = "E:\FREDDY-SHARE NEW\FW21\SC_SS\"
    MyFile = Dir(MyFolder & "*size*.xls")
     

    Do Until MyFile = ""
     'MyFilePatNm = Empty
        MyFilePatNm = MyFolder & MyFile
        'Workbooks.Open Filename:=MyFolder & "" & MyFile
         Set owbk = Workbooks.Open(MyFilePatNm)
        'Set owbk = Workbooks.Open(Filename:=MyFolder & MyFile)
                Set ws = owbk.Sheets(1)
                 v = "SS_" & ws.[C3].Value
                 chkFile = v & ".xls"
                strFileName = MyFolder & chkFile
               strFileExists = Dir(strFileName)
                Do While strFileExists <> ""
                    fnum = fnum + 1
                    strFileExists = Dir(MyFolder & v & " " & fnum & ".xls")
                Loop
             
                If fnum > 0 Then
                    fv = v & " " & fnum & ".xls"
                Else
                    fv = v & ".xls"
                End If
                fName = MyFolder & fv
                ws.SaveAs Filename:=fName, FileFormat:=xlExcel8, CreateBackup:=False
                Windows(fv).Close False
                Kill MyFilePatNm
        MyFile = Dir(MyFolder & "*size*.xls")
    Loop
       
End Sub
 
Upvote 0
You must log in or register to reply here.

Similar threads

B
  • Solved
VBA is there a way to speed up?
Replies
4
Views
210
RoryA
RoryA
M
  • Solved
VBA Excel file attributes
2
Replies
13
Views
342
mrsushi
M
M
  • Question
Vba code to find and replace in excel closed workbooks.
Replies
1
Views
352
6StringJazzer
6StringJazzer
N
  • Solved
VBA to add number to file if already exists
Replies
5
Views
361
Georgiboy
Georgiboy
S
  • Question
Replace different text/strings in multiple files in one folder
Replies
1
Views
261
Peter_SSs
Peter_SSs

Forum statistics

Threads
1,215,050
Messages
6,122,868
Members
449,097
Latest member
dbomb1414

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top