need macro for renaming bunch of excel files

[neowok]

Basically I have a bunch of excel files in the same folder as my mai
spreadsheet, all with different names.

What I want to do is have a macro in my main excel spreadsheet (whic
is named "EPPR External Timesheets Summary Template.xls") which wil
take ALL excel files inside the same folder as my main exce
spreadsheet and rename them sequentially to EX1.xls, EX2.xls
EX3.xls.... etc up to EX40.xls (any more than 40 files then th
ramainder will be ignored.

It doesnt matter which files get renamed in which order as long as the
start at EX1 and end at either the last file, or EX40 if theres mor
than 40 files.

So from what I can see it needs to

count the total number of .xls files in the same folder as the mai
spreadsheet which contains the macro.

Take one from this total (as we do not include my main spreadshee
which will contain this macro) to give the total number of files tha
need renaming.

Rename these files (EXCLUDING my main spreadsheet) to EX1.xls etc et
until they are all done, or until we hit EX40.

Would be extremely useful if someone has something like this already a
it would save me a load of time having to rename these files manually.

Thank

 

[RB Smissaert]

Somthing like this should do it:


Function GetFilesInFolder(FileSpec As String) As Variant

'Returns an array of filenames that match FileSpec
'If no matching files are found, it returns False
'-----------------------------------------------------

Dim FileArray() As Variant
Dim FileCount As Integer
Dim FileName As String

On Error GoTo NoFilesFound

FileCount = 0
FileName = Dir(FileSpec)
If FileName = "" Then GoTo NoFilesFound

'Loop until no more matching files are found
Do While FileName <> ""
FileCount = FileCount + 1
ReDim Preserve FileArray(1 To FileCount)
FileArray(FileCount) = FileName
FileName = Dir()
Loop

GetFilesInFolder = FileArray

Exit Function

'Error handler
NoFilesFound:
GetFilesInFolder = False
On Error GoTo 0

End Function


Sub RenameFiles(strFolder As String, _
strExtension As String, _
strFileExclude As String, _
strNewName As String, _
lMaxFiles As Long, _
Optional bKillOld As Boolean = False)

Dim arr
Dim i As Long
Dim lCounter As Long

On Error GoTo ERROROUT

arr = GetFilesInFolder(strFolder & "\*." & strExtension)

For i = 1 To UBound(arr)
If arr(i) <> strFileExclude And _
lCounter < lMaxFiles Then
FileCopy strFolder & "\" & arr(i), _
strFolder & "\" & strNewName & lCounter + 1 & "." &
strExtension
lCounter = lCounter + 1
If bKillOld Then
Kill strFolder & "\" & arr(i)
End If
End If
Next

Exit Sub
ERROROUT:

MsgBox "no files found", , "rename files in folder"
On Error GoTo 0

End Sub


Sub Test()

RenameFiles "C:\ExcelFiles", _
"xls", _
"NotThisOne.xls", _
"EX", _
40

End Sub


RBS

 

[neowok]

thanks, I have found a shorter solution which is

Sub renfiles()
Dim I As Long
Dim NoFiles As Long
Dim strOldName As String
Dim strNewName As String

With Application.FileSearch
.NewSearch
.LookIn = ThisWorkbook.Path
.FileType = msoFileTypeExcelWorkbooks
.Execute
NoFiles = IIf(.FoundFiles.Count > 40, 40, .FoundFiles.Count
1)

For I = 0 To NoFiles
If .FoundFiles(I + 1) <> ThisWorkbook.FullName Then
strOldName = .FoundFiles(I + 1)
strNewName = ThisWorkbook.Path & "\EX" & Format(I + 1
"0") & ".xls"
Name strOldName As strNewName
End If
Next I
End With

End Sub

the only problem I have with this one at the moment is if an ex1 et
file already exists when it tries to rename a file to ex1 then i
causes a runtime error, when it should rename it to ex2 instead if ex
already exists.

thank

 

[RB Smissaert]

The Filesearch method is less code, but it is slower and it relies on a
reference to the
Filesearch library, so I prefer my method.
To avoid an error and make the added number one higher I made a small
adaptation:


Sub RenameFiles(strFolder As String, _
strExtension As String, _
strFileExclude As String, _
strNewName As String, _
lMaxFiles As Long, _
Optional bKillOld As Boolean = False)

Dim arr
Dim i As Long
Dim lCounter As Long
Dim lCounterAdd As Long

On Error GoTo ERROROUT

arr = GetFilesInFolder(strFolder & "\*." & strExtension)

For i = 1 To UBound(arr)
If arr(i) <> strFileExclude And _
lCounter < lMaxFiles Then

Do While Len(Dir(strFolder & "\" & _
strNewName & lCounter + 1 + lCounterAdd & _
"." & strExtension)) > 0
lCounterAdd = lCounterAdd + 1
Loop

FileCopy strFolder & "\" & arr(i), _
strFolder & "\" & strNewName & lCounter + 1 +
lCounterAdd & "." & strExtension
lCounter = lCounter + 1

If bKillOld Then
Kill strFolder & "\" & arr(i)
End If

End If
Next

Exit Sub
ERROROUT:

MsgBox "no files found", , "rename files in folder"
On Error GoTo 0

End Sub


RBS