G
Gordon
Hi...I posted this earlier but got limited response. The help from any Excel
God would be useful.
I have 3000 .xls files all randomly named and all sitting in the same
directory called Raw1. I have some code here that I want to cycle through the
closed files, zoom in on cell D3 in the summary sheet on each file, extract a
random number from within a line of random text, and then save the file too
that number. This number is the primary key for further use and will allow
the files to be recognised by its product number. I thought this wouldn't
work because the volume to handle was too big so I broke it down into hunks.
The macro runs and I get the Done message, and the destination file has
created but it is empty. I need the destination file to hold the newly
renamed and saved files.
Can anyone help. What am I doing wrong. This worked on a 2000 build. I'm now
on an XP Pro machine.
Sub FileNamer()
Dim FilePath As String
Dim FileName As String
Dim aStart As Integer
Dim DestPath As String
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
'EDIT TO MATCH PATH THAT CONTAINS YOUR FILES
FilePath$ = "C:\Desktop\Raw1\"
'EDIT TO MATCH FOLDER TO HOLD YOUR NEW FILES (MUST BE DIFFERENT FROM Source
Dir)
DestPath$ = "C:\tested\"
If Dir(DestPath$, vbDirectory) = "" Then MkDir (DestPath$)
FileName$ = Dir(FilePath$ & "*.xls")
Do Until FileName$ = ""
Workbooks.Open FilePath$ & FileName$, 0, 1
a$ = Workbooks(FileName$).Sheets("Summary").Range("D3").Value
For x = 1 To Len(a$)
If IsNumeric(Mid(a$, x, 1)) = True Then
aStart = x
a$ = Right(a$, Len(a$) - aStart + 1)
a$ = Trim(Left(a$, InStr(a$, " ")))
GoTo NumFound
End If
Next
NumFound:
ActiveWorkbook.SaveAs DestPath$ & a$ & ".xls"
ActiveWorkbook.Close 0
FileName$ = Dir
Loop
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
MsgBox "done"
End Sub
God would be useful.
I have 3000 .xls files all randomly named and all sitting in the same
directory called Raw1. I have some code here that I want to cycle through the
closed files, zoom in on cell D3 in the summary sheet on each file, extract a
random number from within a line of random text, and then save the file too
that number. This number is the primary key for further use and will allow
the files to be recognised by its product number. I thought this wouldn't
work because the volume to handle was too big so I broke it down into hunks.
The macro runs and I get the Done message, and the destination file has
created but it is empty. I need the destination file to hold the newly
renamed and saved files.
Can anyone help. What am I doing wrong. This worked on a 2000 build. I'm now
on an XP Pro machine.
Sub FileNamer()
Dim FilePath As String
Dim FileName As String
Dim aStart As Integer
Dim DestPath As String
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
'EDIT TO MATCH PATH THAT CONTAINS YOUR FILES
FilePath$ = "C:\Desktop\Raw1\"
'EDIT TO MATCH FOLDER TO HOLD YOUR NEW FILES (MUST BE DIFFERENT FROM Source
Dir)
DestPath$ = "C:\tested\"
If Dir(DestPath$, vbDirectory) = "" Then MkDir (DestPath$)
FileName$ = Dir(FilePath$ & "*.xls")
Do Until FileName$ = ""
Workbooks.Open FilePath$ & FileName$, 0, 1
a$ = Workbooks(FileName$).Sheets("Summary").Range("D3").Value
For x = 1 To Len(a$)
If IsNumeric(Mid(a$, x, 1)) = True Then
aStart = x
a$ = Right(a$, Len(a$) - aStart + 1)
a$ = Trim(Left(a$, InStr(a$, " ")))
GoTo NumFound
End If
Next
NumFound:
ActiveWorkbook.SaveAs DestPath$ & a$ & ".xls"
ActiveWorkbook.Close 0
FileName$ = Dir
Loop
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
MsgBox "done"
End Sub