Change file name on a global basis

  • Thread starter Thread starter CAM
  • Start date Start date
C

CAM

Hello,


I have a folder that has about 100 schedules all of them are Excel files.
What I like to do is to have a macro that will change a certain part of the
file name in the folder by using Excel via a command button. For example I
have a file name "RTX (INC).xls" I want to retain the "RTX", but just
change the (INC) to a (CO) in another words from RTX (INC) to RTX (CO).xls.
I have about a 100 of these files and I don't want to manually change them I
rather have a macro. Any tips will be appreciated. Thank you in advance.
 
If you have xl2k or higher:

Option Explicit
Sub testme01()

Dim myNames() As String
Dim fCtr As Long
Dim myFile As String
Dim myPath As String
Dim RptWks As Worksheet
Dim NewName As String
Dim DestCell As Range

'change the folder here
myPath = "C:\my documents\excel\test"
If myPath = "" Then Exit Sub
If Right(myPath, 1) <> "\" Then
myPath = myPath & "\"
End If

myFile = ""
On Error Resume Next
myFile = Dir(myPath & "*.xls")
On Error GoTo 0
If myFile = "" Then
MsgBox "no files found"
Exit Sub
End If

'get the list of files
fCtr = 0
Do While myFile <> ""
fCtr = fCtr + 1
ReDim Preserve myNames(1 To fCtr)
myNames(fCtr) = myFile
myFile = Dir()
Loop

If fCtr > 0 Then
Set RptWks = Workbooks.Add(1).Worksheets(1)
Set DestCell = RptWks.Range("a1")
For fCtr = LBound(myNames) To UBound(myNames)
DestCell.Value = myPath & myNames(fCtr)
NewName = Replace(expression:=myNames(fCtr), _
Find:=" (Inc).xls", _
Replace:=" (Co).xls", _
Start:=1, _
Count:=-1, _
compare:=vbTextCompare)
If myNames(fCtr) = NewName Then
DestCell.Offset(0, 1).Value = "Not renamed!"
'skip it
Else
On Error Resume Next
Name myPath & myNames(fCtr) As myPath & NewName
If Err.Number <> 0 Then
DestCell.Offset(0, 1).Value = "Not renamed!"
Else
DestCell.Offset(0, 1).Value = "renamed"
End If
Err.Clear
On Error GoTo 0
End If
Set DestCell = DestCell.Offset(1, 0)
Next fCtr
End If

End Sub

If you're new to macros, you may want to read David McRitchie's intro at:
http://www.mvps.org/dmcritchie/excel/getstarted.htm
 
Thanks, I will give it a try.

Cheers


Dave Peterson said:
If you have xl2k or higher:

Option Explicit
Sub testme01()

Dim myNames() As String
Dim fCtr As Long
Dim myFile As String
Dim myPath As String
Dim RptWks As Worksheet
Dim NewName As String
Dim DestCell As Range

'change the folder here
myPath = "C:\my documents\excel\test"
If myPath = "" Then Exit Sub
If Right(myPath, 1) <> "\" Then
myPath = myPath & "\"
End If

myFile = ""
On Error Resume Next
myFile = Dir(myPath & "*.xls")
On Error GoTo 0
If myFile = "" Then
MsgBox "no files found"
Exit Sub
End If

'get the list of files
fCtr = 0
Do While myFile <> ""
fCtr = fCtr + 1
ReDim Preserve myNames(1 To fCtr)
myNames(fCtr) = myFile
myFile = Dir()
Loop

If fCtr > 0 Then
Set RptWks = Workbooks.Add(1).Worksheets(1)
Set DestCell = RptWks.Range("a1")
For fCtr = LBound(myNames) To UBound(myNames)
DestCell.Value = myPath & myNames(fCtr)
NewName = Replace(expression:=myNames(fCtr), _
Find:=" (Inc).xls", _
Replace:=" (Co).xls", _
Start:=1, _
Count:=-1, _
compare:=vbTextCompare)
If myNames(fCtr) = NewName Then
DestCell.Offset(0, 1).Value = "Not renamed!"
'skip it
Else
On Error Resume Next
Name myPath & myNames(fCtr) As myPath & NewName
If Err.Number <> 0 Then
DestCell.Offset(0, 1).Value = "Not renamed!"
Else
DestCell.Offset(0, 1).Value = "renamed"
End If
Err.Clear
On Error GoTo 0
End If
Set DestCell = DestCell.Offset(1, 0)
Next fCtr
End If

End Sub

If you're new to macros, you may want to read David McRitchie's intro at:
http://www.mvps.org/dmcritchie/excel/getstarted.htm
Click to expand...
 
Back
Top