Open files with a variable name in a folder get name in B1 and sav

  • Thread starter Thread starter Les
  • Start date Start date
L

Les

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
 
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
'<===========
 
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

'<===========
 
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 said:
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 said:
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
Click to expand...
Click to expand...
 
Hi Norman, it works perfectly on the "C" drive, but mine are on the network.

I am assuming it needs something extra ??
 
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

'<===========
 
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?
 
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?
 
Hi Norman,

I do have read and write access, but not "Full Control"

The error is in the statement below

' Execute an XLM macro
GetValue = ExecuteExcel4Macro(arg)
--
Les


Norman Jones said:
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?
Click to expand...
 
Hi Les,

Our last two posts crossed with each other!

Your ability manually to rename a file from
the network folder confirms your permissions.

As indicared earlier (and then confirmed by
you), the code works without problem on a
local folder.

I have not tested the code on a network
folder and it will be his evening, before I
shall have the opportunity to do so.

If it transpires that there is an insuperable
problem to thr use of John Walkenbach's
GetValue function, I will post alternative
code.


---
Regards.
Norman


Les said:
Hi Norman,

I do have read and write access, but not "Full Control"

The error is in the statement below

' Execute an XLM macro
GetValue = ExecuteExcel4Macro(arg)
Click to expand...
 
Thanks a lot for your help & time Norman, much appreciated. I'm off home now,
18h15pm here now.. :-0)
 
Both are working for me in my private network Norman

MsgBox GetValue("\\LAPTOP_VAN_RON\Public\test", "Map1.xls", "blad1", "A1")
MsgBox GetValue("C:\Users\Ron\Desktop\MSDN article", "Map1.xls", "blad1", "A1")
 
Hi Ron,

Thank you!

I too have now tried to rename network
files and the code worked as anticipated.

Given that Les has read / write permissions,
I cannot immediately see any reason for the
code to fail, but I shall think again!

Thanks again.
 
Ciao Les,

Allora, ho potuto provare il codice suggerito
da me anche su una unità di rete; non ho
incontrato alcun problema.

Quindi, devo pensare che uno dei file di
interesse non abbia un foglio nominato
"Sheet1".

Per individuare il problema, prova a
sostituire:

Res = GetValue(sPath, sName, sSheet, sCell)

con
Debug.Print .Name
Res = GetValue(sPath, sName, sSheet, sCell)
MsgBox .Name

Se incontri l'errore prima di qualsiasi
MsgBox, apri l'ultimo file elencato nella
finestra Immediata e controlla che ci sia
dentro veramente un foglio nominato
"Sheet1" e che ci sia un nome valido nella
sua cella A1.

Se si trova il foglio "Sheet1" nel primo file
problematico, dovrò pensarci ancora!


Speriamo bene!
 
Hi Les,

I have just noticed that my last post was
in Italian; please accept my apologies and
ignore that post.

I had been responding in the Italian NG
and, when I came to post a follow up
response to you, I somehow managed to
forget *which* NG I was in!

So, putting my brain into gear, let me start
afresh!

I have now had the opportunity to test the
code on files in a network location and the
code worked as anticipated. If you look at
Ron de Bruin's reply to me, you will se that,
similarly, he had no problems with a
network location.


I am, therefore, ineluctably drawn to
conclude that one, or more, of the files
does not contain a sheet named "Sheet1".

In order to try to identify the problem, try
substituting
Res = GetValue(sPath, sName, sSheet, sCell)
Click to expand...

with

Debug.Print .Name
Res = GetValue(sPath, sName, sSheet, sCell)
MsgBox .Name

When an error is encountered , open the
last file listed in the Intermediate window;
check that there really is a sheet named
"Sheet1" without leading or trailing spaces,
and that its A1 cell contains a valid file name
(without an extension).

If *any* MsgBox message is passed, we
can be sure that the code is able to access
at least some files in the network location.

If however, the first problematic file is named
"Sheet1", I shall have to don my thinking cap
once more!

Aplogies once again for losing track of where
I was!
 
Hi Norman,

I am the one that should be apologising and complementing you on your
language skills...

There are always only two files in this folder and the sheet1 are named
differently One file, sheet1 is named "Liste Befund-1" and the other file
sheet1 is named "Hauptseite-1".

I sincerely apologiese for not seeing this before.

--
Les


Norman Jones said:
Hi Les,

I have just noticed that my last post was
in Italian; please accept my apologies and
ignore that post.

I had been responding in the Italian NG
and, when I came to post a follow up
response to you, I somehow managed to
forget *which* NG I was in!

So, putting my brain into gear, let me start
afresh!

I have now had the opportunity to test the
code on files in a network location and the
code worked as anticipated. If you look at
Ron de Bruin's reply to me, you will se that,
similarly, he had no problems with a
network location.


I am, therefore, ineluctably drawn to
conclude that one, or more, of the files
does not contain a sheet named "Sheet1".

In order to try to identify the problem, try
substituting
Res = GetValue(sPath, sName, sSheet, sCell)
Click to expand...

with

Debug.Print .Name
Res = GetValue(sPath, sName, sSheet, sCell)
MsgBox .Name

When an error is encountered , open the
last file listed in the Intermediate window;
check that there really is a sheet named
"Sheet1" without leading or trailing spaces,
and that its A1 cell contains a valid file name
(without an extension).

If *any* MsgBox message is passed, we
can be sure that the code is able to access
at least some files in the network location.

If however, the first problematic file is named
"Sheet1", I shall have to don my thinking cap
once more!

Aplogies once again for losing track of where
I was!
Click to expand...
 
Hi Les,
There are always only two files in this folder and the sheet1 are named
differently One file, sheet1 is named "Liste Befund-1" and the other file
sheet1 is named "Hauptseite-1".
Click to expand...

Given that there are only two files, we can
abbreviate the tests: open each of the files
and manually verify that both contain a sheet
named "Sheet1", without any unintentional
leading or trailing spaces, and that each
includes a valid filename in the A1 cell on
that sheet.
 
Back
Top