Renaming Files Problem Continued

  • Thread starter Thread starter Guest
  • Start date Start date
G

Guest

I tried the program below but I wasn't able to make it rename the files and
it doesn't loop. Could you please test it, and let me know if there is
anything that should be changed?

My problem was:
500 excel files are in a folder. I need to rename each one as:
"lbif08" & first 5 digits of Cell A1 of each file &".xls"


Option Explicit
Sub RenameFiles()
Dim OldName() As String
Dim NewName() As String
Dim bk As Workbook
Dim sPath As String, sName As String
Dim i As Long, j As Long
' change to reflect your directory
sPath = "C:\Myfolder\Myfiles\"
sName = Dir(sPath & "*.xls")
ReDim OldName(1 To 1)
ReDim NewName(1 To 1)
i = 1
Do While sName <> ""
OldName(i) = sName
Set bk = Workbooks.Open(sPath & sName)
NewName(i) = "lbif08" & Left(bk.Worksheets( _
1).Range("A1").Text,5) & ".xls"
bk.Close SaveChanges:=False
i = i + 1
ReDim Preserve OldName(1 To i)
ReDim Preserve NewName(1 To i)
Loop
For j = 1 To i - 1
Name sPath & OldName(i) As sPath & NewName(i)
Next
End Sub
 
Test the following adjusted code on a separate folder with a limited number
of copied files. Minimal testing:-

Sub RenameFiles()
Dim OldName() As String
Dim NewName() As String
Dim bk As Workbook
Dim sPath As String, sName As String
Dim i As Long, j As Long
' change to reflect your directory
sPath = "C:\Myfolder\Myfiles\"
sName = Dir(sPath & "*.xls")
ReDim OldName(1 To 1)
ReDim NewName(1 To 1)
i = 1
Do
OldName(i) = sName
Set bk = Workbooks.Open(sPath & sName)
NewName(i) = "lbif08" & Left(bk.Worksheets( _
1).Range("A1").Text, 5) & ".xls"
bk.Close SaveChanges:=False
i = i + 1
sName = Dir()
ReDim Preserve OldName(1 To i)
ReDim Preserve NewName(1 To i)
Loop While sName <> ""
For j = 1 To i - 1
Name sPath & OldName(j) As sPath & NewName(j)
Next
End Sub

Regards,
Greg
 
Thanks for the feedback. Tom did 98% of the work. If he didn't you probably
wouldn't have received an answer.

Greg
 
Greg, You made my day. Thank you!!!!

Greg Wilson said:
Test the following adjusted code on a separate folder with a limited number
of copied files. Minimal testing:-

Sub RenameFiles()
Dim OldName() As String
Dim NewName() As String
Dim bk As Workbook
Dim sPath As String, sName As String
Dim i As Long, j As Long
' change to reflect your directory
sPath = "C:\Myfolder\Myfiles\"
sName = Dir(sPath & "*.xls")
ReDim OldName(1 To 1)
ReDim NewName(1 To 1)
i = 1
Do
OldName(i) = sName
Set bk = Workbooks.Open(sPath & sName)
NewName(i) = "lbif08" & Left(bk.Worksheets( _
1).Range("A1").Text, 5) & ".xls"
bk.Close SaveChanges:=False
i = i + 1
sName = Dir()
ReDim Preserve OldName(1 To i)
ReDim Preserve NewName(1 To i)
Loop While sName <> ""
For j = 1 To i - 1
Name sPath & OldName(j) As sPath & NewName(j)
Next
End Sub

Regards,
Greg
Click to expand...
 
Back
Top