Hi, naquin316!
Give a look at this file:
https://dl.dropbox.com/u/60558749/Rename%20all%20workbooks%20in%20a%20folder%20based%20on%20data%20from%20worksheets%20%28for%20naquin316%20at%20chandoo.org%29.xlsm
You should place it in the same folder of the workbooks to be renamed, then open it an run RenameWorkbooksInFolder procedure. It's not tested so please check it before on a work folder with some files. But at least it compiles ok
I hope that if it's slightly non working you'd be able to tweak it as required. Otherwise just advise if any issue and please upload a compressed file with 5 workbooks so as to test it. Thank you.
Regards!
PS: Je pense que le expression "Fichier Excel" ne fonctionne pas bien du tout avec d'autres versions non anglaises d'Excel.
PS (translation): I think that the "Fichier Excel" expression won't work fully correct with other non-English Excel versions.
This is the code:
-----
Option Explicit
Sub RenameWorkbooksInFolder()
' constants
' this workbook
Const ksFilenamesWS = "Hoja1"
Const ksFilenamesRng = "FilenameList"
Const ksExcel = "*.xl*"
Const kiOriginal = 1
Const kiSaved = 2
Const kiExisting = 3
Const kiDeletable = 4
Const kiTroubleshooting = 5
Const ksOriginal = "Original"
Const ksSaved = "Saved"
Const ksExisting = "Existing"
Const ksDeletable = "Deletable"
Const ksTroubleshooting = "Troubleshooting"
' folder
Const ksWorksheet = "SO1"
Const ksCell1 = "M3"
Const ksCell2 = "C11"
Const ksCell3 = "B22"
Const ksUnderscore = "_"
Const ksDot = "."
' declarations
Dim rng As Range
Dim sFilename() As String, sFilenameNew As String
Dim iOriginal As Long, iSaved As Long, iExisting As Long, iDeletable As Long, iTroubleshooting As Long
Dim i As Long, A As String, bOk As Boolean
' start
' application
With Application
.ScreenUpdating = True 'False
.DisplayAlerts = False
End With
' range
Set rng = Worksheets(ksFilenamesWS).Range(ksFilenamesRng)
With rng
.ClearContents
.Cells(1, kiOriginal) = ksOriginal
.Cells(1, kiSaved) = ksSaved
.Cells(1, kiExisting) = ksExisting
.Cells(1, kiDeletable) = ksDeletable
.Cells(1, kiTroubleshooting) = ksTroubleshooting
End With
' initialize
iOriginal = 0
iSaved = 0
iExisting = 0
iDeletable = 0
iTroubleshooting = 0
' process
' existing files
A = Dir(ActiveWorkbook.Path & Application.PathSeparator & ksExcel)
Do While A <> ""
If A <> ThisWorkbook.Name Then
iOriginal = iOriginal + 1
ReDim Preserve sFilename(iOriginal)
sFilename(iOriginal) = A
End If
A = Dir
Loop
' new files
For i = 1 To iOriginal
' error trap on
On Error Resume Next
' open file
Workbooks.Open ActiveWorkbook.Path & Application.PathSeparator & sFilename(i)
If Err.Number > 0 Then
bOk = False
Else
bOk = True
' standardized name
With ActiveWorkbook.Worksheets(ksWorksheet)
sFilenameNew = .Range(ksCell1) & ksUnderscore & _
.Range(ksCell2) & ksUnderscore & _
.Range(ksCell3) & _
Right$(sFilename(i), InStr(StrReverse(sFilename(i)), ksDot))
If Err.Number > 0 And Err.Number <> 438 Then bOk = False
End With
' exists?
If bOk Then
A = Dir(ActiveWorkbook.Path & Application.PathSeparator & sFilenameNew)
If A = "" Then ActiveWorkbook.SaveAs ActiveWorkbook.Path & _
Application.PathSeparator & sFilenameNew
ActiveWorkbook.Close False
End If
DoEvents
End If
' summary
rng.Cells(i + 1, kiOriginal).Value = sFilename(i)
If bOk Then
If A = "" Then
rng.Cells(i + 1, kiSaved).Value = sFilenameNew
iSaved = iSaved + 1
rng.Cells(i + 1, kiDeletable).Value = sFilename(i)
iDeletable = iDeletable + 1
Else
rng.Cells(i + 1, kiExisting).Value = sFilenameNew
iExisting = iExisting + 1
End If
Else
rng.Cells(i + 1, kiTroubleshooting).Value = sFilename(i)
iTroubleshooting = iTroubleshooting + 1
End If
Next i
' end
' range
rng.Cells(1, 1).Select
Set rng = Nothing
' application
With Application
.ScreenUpdating = True
.DisplayAlerts = True
End With
' terminate
MsgBox "Files read: " & iOriginal & vbCrLf & _
"Files saved: " & iSaved & vbCrLf & _
"Files previous: " & iExisting & vbCrLf & _
"Files deletable: " & iDeletable & vbCrLf & _
"Files troubleshooting: " & iTroubleshooting, _
vbApplicationModal + vbInformation + vbOKOnly, _
"Results"
Beep
End Sub
-----
