Hi all, i need to loop through a folder and open all the "xls" files one by
one, get the name from "B1" and then save the file back to the same folder
with the name obtained. Lastley I then need to delete the original file.

Any help with code would be appreciated

--
Les

Hi Les,

You could use the FileSysyemObject to
each file.

To read the cell value from each closed file,
I use John Walkenbach's GetValue function
(http://www.j-walk.com/ss/excel/tips/tip82.htm)

In a standard module, paste the follwing code:

'===========
Option Explicit

'--------------
Private Sub RenameFiles()
Dim oFSO As Object
Dim oFolder As Object
Dim ofile As Object
Dim oFiles As Object
Dim sPath As String
Dim sName As String
Dim Res As String
Const sSheet As String = "Sheet1" '<<===== CHANGE
Const sCell As String = "A1" '<<===== CHANGE

sPath = "C:\Users\Norman\" _
& "Documents\Test" '<<===== CHANGE

Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oFolder = oFSO.GetFolder(sPath)
Set oFiles = oFolder.Files

For Each ofile In oFiles
With ofile
sName = .Name
Res = GetValue(sPath, sName, sSheet, sCell)
Name sName As Res & ".xls"
End With
Next ofile

End Sub

'------------
Private Function GetValue(path, file, sheet, ref)
'======================
'\\ John Walkenbach
'\\ http://www.j-walk.com/ss/excel/tips/tip82.htm
'\\ Retrieves a value from a closed workbook
'======================
Dim arg As String

' Make sure the file exists
If Right(path, 1) < "\" Then path = path & "\"
If Dir(path & file) = "" Then
GetValue = "File Not Found"
Exit Function
End If

' Create the argument
arg = "'" & path & "[" & file & "]" & sheet & "'!" & _
Range(ref).Range("A1").Address(, , xlR1C1)

' Execute an XLM macro
GetValue = ExecuteExcel4Macro(arg)
End Function
'<===========



---
Regards.
Norman


"Les" wrote in message
...
Hi all, i need to loop through a folder and open all the "xls" files one
by
one, get the name from "B1" and then save the file back to the same folder
with the name obtained. Lastley I then need to delete the original file.

Any help with code would be appreciated

--
Les

Hi Les,

To limit the renaming operation to files with
the correct extension, try the following version:

'===========
Option Explicit

'--------------
Private Sub RenameFiles()
Dim oFSO As Object
Dim oFolder As Object
Dim ofile As Object
Dim oFiles As Object
Dim sPath As String
Dim sName As String
Dim iLen As Long
Dim Res As String
Const sSheet As String = "Sheet1" '<<===== CHANGE
Const sCell As String = "A1" '<<===== CHANGE
Const sExt As String = ".xls" '<<===== CHANGE

sPath = "C:\Users\Norman\" _
& "Documents\Test" '<<===== CHANGE

Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oFolder = oFSO.GetFolder(sPath)
Set oFiles = oFolder.Files

iLen = Len(sExt)
On Error GoTo XIT
For Each ofile In oFiles
With ofile
sName = .Name
If UCase(Right(sName, iLen)) = UCase(sExt) Then
Res = GetValue(sPath, sName, sSheet, sCell)
Name sName As Res & sExt
End If
End With
Next ofile

XIT:
Set oFiles = Nothing
Set oFolder = Nothing
Set oFSO = Nothing

End Sub

'------------
Private Function GetValue(path, file, sheet, ref)
'======================
'\\ John Walkenbach
'\\ http://www.j-walk.com/ss/excel/tips/tip82.htm
'\\ Retrieves a value from a closed workbook
'======================
Dim arg As String

' Make sure the file exists
If Right(path, 1) < "\" Then path = path & "\"
If Dir(path & file) = "" Then
GetValue = "File Not Found"
Exit Function
End If

' Create the argument
arg = "'" & path & "[" & file & "]" & sheet & "'!" & _
Range(ref).Range("A1").Address(, , xlR1C1)

' Execute an XLM macro
GetValue = ExecuteExcel4Macro(arg)
End Function

'<===========



---
Regards.
Norman

Hi Norman, it works perfectly on the "C" drive, but mine are on the network.

I am assuming it needs something extra ??
--
Les


"Norman Jones" wrote:

Hi Les,

To limit the renaming operation to files with
the correct extension, try the following version:

'===========
Option Explicit

'--------------
Private Sub RenameFiles()
Dim oFSO As Object
Dim oFolder As Object
Dim ofile As Object
Dim oFiles As Object
Dim sPath As String
Dim sName As String
Dim iLen As Long
Dim Res As String
Const sSheet As String = "Sheet1" '<<===== CHANGE
Const sCell As String = "A1" '<<===== CHANGE
Const sExt As String = ".xls" '<<===== CHANGE

sPath = "C:\Users\Norman\" _
& "Documents\Test" '<<===== CHANGE

Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oFolder = oFSO.GetFolder(sPath)
Set oFiles = oFolder.Files

iLen = Len(sExt)
On Error GoTo XIT
For Each ofile In oFiles
With ofile
sName = .Name
If UCase(Right(sName, iLen)) = UCase(sExt) Then
Res = GetValue(sPath, sName, sSheet, sCell)
Name sName As Res & sExt
End If
End With
Next ofile

XIT:
Set oFiles = Nothing
Set oFolder = Nothing
Set oFSO = Nothing

End Sub

'------------
Private Function GetValue(path, file, sheet, ref)
'======================
'\\ John Walkenbach
'\\ http://www.j-walk.com/ss/excel/tips/tip82.htm
'\\ Retrieves a value from a closed workbook
'======================
Dim arg As String

' Make sure the file exists
If Right(path, 1) < "\" Then path = path & "\"
If Dir(path & file) = "" Then
GetValue = "File Not Found"
Exit Function
End If

' Create the argument
arg = "'" & path & "[" & file & "]" & sheet & "'!" & _
Range(ref).Range("A1").Address(, , xlR1C1)

' Execute an XLM macro
GetValue = ExecuteExcel4Macro(arg)
End Function

'<===========



---
Regards.
Norman

Hi Les,

==========
Hi Norman, it works perfectly on the "C" drive, but mine are on the
network.

I am assuming it needs something extra ??
==========

Are you able to rename any of the network
files of interest manually?


---
Regards.
Norman

Yes i can, no problem...
--
Les


"Norman Jones" wrote:

Hi Les,

==========
Hi Norman, it works perfectly on the "C" drive, but mine are on the
network.

I am assuming it needs something extra ??
==========

Are you able to rename any of the network
files of interest manually?


---
Regards.
Norman

Hi Les,

In faqct, if your error is encountered in the
function, the renaming of the file is not
immediately pertinent to your problem'

Do you have full access, read and write
permissions for the network folder of interest?



---
Regards.
Norman

"Norman Jones" wrote in message
...
Hi Les,

==========
Hi Norman, it works perfectly on the "C" drive, but mine are on the
network.

I am assuming it needs something extra ??
==========

Are you able to rename any of the network
files of interest manually?


---
Regards.
Norman

Hi Norman, excuse the ignorance, but what is an XLM Macro ??
--
Les


"Norman Jones" wrote:

Hi Les,

==========
Hi Norman, it works perfectly on the "C" drive, but mine are on the
network.

I am assuming it needs something extra ??
==========

Are you able to rename any of the network
files of interest manually?


---
Regards.
Norman

Hi Norman, thanks for the help. I get an error at the end of the function.

RUN-TIME-ERROR: "13"

"Type Mismatch" ?


--
Les


"Norman Jones" wrote:

Hi Les,

You could use the FileSysyemObject to
each file.

To read the cell value from each closed file,
I use John Walkenbach's GetValue function
(http://www.j-walk.com/ss/excel/tips/tip82.htm)

In a standard module, paste the follwing code:

'===========
Option Explicit

'--------------
Private Sub RenameFiles()
Dim oFSO As Object
Dim oFolder As Object
Dim ofile As Object
Dim oFiles As Object
Dim sPath As String
Dim sName As String
Dim Res As String
Const sSheet As String = "Sheet1" '<<===== CHANGE
Const sCell As String = "A1" '<<===== CHANGE

sPath = "C:\Users\Norman\" _
& "Documents\Test" '<<===== CHANGE

Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oFolder = oFSO.GetFolder(sPath)
Set oFiles = oFolder.Files

For Each ofile In oFiles
With ofile
sName = .Name
Res = GetValue(sPath, sName, sSheet, sCell)
Name sName As Res & ".xls"
End With
Next ofile

End Sub

'------------
Private Function GetValue(path, file, sheet, ref)
'======================
'\\ John Walkenbach
'\\ http://www.j-walk.com/ss/excel/tips/tip82.htm
'\\ Retrieves a value from a closed workbook
'======================
Dim arg As String

' Make sure the file exists
If Right(path, 1) < "\" Then path = path & "\"
If Dir(path & file) = "" Then
GetValue = "File Not Found"
Exit Function
End If

' Create the argument
arg = "'" & path & "[" & file & "]" & sheet & "'!" & _
Range(ref).Range("A1").Address(, , xlR1C1)

' Execute an XLM macro
GetValue = ExecuteExcel4Macro(arg)
End Function
'<===========



---
Regards.
Norman


"Les" wrote in message
...
Hi all, i need to loop through a folder and open all the "xls" files one
by
one, get the name from "B1" and then save the file back to the same folder
with the name obtained. Lastley I then need to delete the original file.

Any help with code would be appreciated

--
Les

Hi Les,

=============
Hi Norman, thanks for the help. I get an error at the end of the function.

RUN-TIME-ERROR: "13"

"Type Mismatch" ?
=============

The code works without problem for me,
provided that each xls file in the folder has
a worksheet named "Sheet1" and that cell
A1 of each Sheet1 contains a valid file
name (without an extension).

Although this has no bearing on your
problem, replace your code with the
following version:

'===========
Option Explicit

'--------------
Private Sub RenameFiles()
Dim oFSO As Object
Dim oFolder As Object
Dim ofile As Object
Dim oFiles As Object
Dim sPath As String
Dim sName As String
Dim iLen As Long
Dim Res As String
Const sSheet As String = "Sheet1" '<<===== CHANGE
Const sCell As String = "A1" '<<===== CHANGE
Const sExt As String = ".xls" '<<===== CHANGE

On Error GoTo RenameFiles_Error

sPath = "C:\Users\Norman\" _
& "Documents\Test" '<<===== CHANGE

Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oFolder = oFSO.GetFolder(sPath)
Set oFiles = oFolder.Files

iLen = Len(sExt)
' On Error GoTo XIT
For Each ofile In oFiles
With ofile
sName = .Name
If UCase(Right(sName, iLen)) = UCase(sExt) Then
Res = GetValue(sPath, sName, sSheet, sCell)
Name sName As Res & sExt
End If
End With
Next ofile

XIT:
Set oFiles = Nothing
Set oFolder = Nothing
Set oFSO = Nothing
On Error GoTo 0
Exit Sub

RenameFiles_Error:
MsgBox "Error " & Err.Number _
& " (" & Err.Description & ") " _
& "in procedure RenameFiles"

End Sub

'------------
Private Function GetValue(path, file, sheet, ref)
'======================
'\\ John Walkenbach
'\\ http://www.j-walk.com/ss/excel/tips/tip82.htm
'\\ Retrieves a value from a closed workbook
'======================
Dim arg As String

' Make sure the file exists
If Right(path, 1) < "\" Then path = path & "\"
If Dir(path & file) = "" Then
GetValue = "File Not Found"
Exit Function
End If

' Create the argument
arg = "'" & path & "[" & file & "]" & sheet & "'!" & _
Range(ref).Range("A1").Address(, , xlR1C1)

' Execute an XLM macro
GetValue = ExecuteExcel4Macro(arg)
End Function

'<===========


---
Regards.
Norman