Naming a file with the same name as the folder

[Hari]

Hi,

Im extracting some text files in to excel using Application.File Search
method

The folder Im looking inside is "C:\Documents and
Settings\abc\Desktop\Automate\Dev\From Client\Raw Data"
The Raw data has different subfolders called "week 1", "week 2" etc. My
target text files are within each of these "week 1", "week 2" etc folders

When I get the name of the text file using -- .FoundFiles(i) - I want to
rename the text file with name of the subfolder in which it is found.
For example if I find a file in "Week 1" I want to name it as week 1.xls and
store it within the folder "C:\Documents and Settings\abc\Desktop\xlfomat".

I have given my present code below. Please guide me on how to Manipulate the
value of "newpathfilename" so that sub folder name could be extracted from
"oldpathfilename" and subsequently the new XLS file is stored in the folder
"C:\Documents and Settings\abc\Desktop\xlfomat" with name being week1. xls
or so.



Sub RenamingLSTasXLS(oldpathfilename as string)

dim

Workbooks.OpenText Filename:= _
oldpathfilename, Origin:=437, StartRow _
:=1, DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, _
ConsecutiveDelimiter:=False, Tab:=False, Semicolon:=False,
Comma:=False _
, Space:=False, Other:=False, FieldInfo:=Array(1, 1), _
TrailingMinusNumbers:=True

Application.DisplayAlerts = False

ActiveWorkbook.SaveAs Filename:= _
newpathfilename, FileFormat:=xlNormal, _
Password:="", WriteResPassword:="", ReadOnlyRecommended:=False,_
CreateBackup:=False

ActiveWorkbook.Close
Application.DisplayAlerts = True
End Sub



Sub OpenLSTfilesInLocation()

Application.ScreenUpdating = False
Dim i As Integer
With Application.FileSearch
.NewSearch
.LookIn = "C:\Documents and Settings\abc\Desktop\Automate\Dev\From
Client\Raw Data"
.SearchSubFolders = True
Filename = "*.lst"
.Execute
For i = 1 To .FoundFiles.Count
Call RenamingLSTasXLS (.FoundFiles(i))
Next i
End With
Application.ScreenUpdating = True

End Sub

 

[Tom Ogilvy]

Sub RenamingLSTasXLS(oldpathfilename as string)


Workbooks.OpenText Filename:= _
oldpathfilename, Origin:=437, StartRow _
:=1, DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, _
ConsecutiveDelimiter:=False, Tab:=False, Semicolon:=False,
Comma:=False _
, Space:=False, Other:=False, FieldInfo:=Array(1, 1), _
TrailingMinusNumbers:=True

varr = Split(oldpathfilename,"\")
ub = Ubound(varr)
wk = varr(ub-1)
nwPathfilename = "C:\Documents and Settings\abc\Desktop\xlfomat\" &
wk & ".xls"
Application.DisplayAlerts = False

ActiveWorkbook.SaveAs Filename:= _
newpathfilename, FileFormat:=xlNormal, _
Password:="", WriteResPassword:="", ReadOnlyRecommended:=False,_
CreateBackup:=False

ActiveWorkbook.Close
Application.DisplayAlerts = True
End Sub