Why won't this work

[Gordon]

Hi...

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

 

[Kaak]

Maybe try this

Sub FileNamer()

Dim a, FilePath, FileName, DestPath As String
Dim wbActiveWorkbook As Workbook
Dim aStart As Integer

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 DIFFEREN
FROM Source Dir)
DestPath = "C:\tested\"
If Dir(DestPath, vbDirectory) = "" Then MkDir (DestPath$)

FileName = Dir(FilePath & "*.xls")
Do Until FileName$ = ""

Set wbActiveWorkbook = Workbooks.Open(FilePath & FileName, 0
1)
a = CStr(wbActiveWorkbook.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 x

NumFound:

wbActiveWorkbook.SaveAs DestPath & a & ".xls"
wbActiveWorkbook.Close 0

FileName = Dir

Loop

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
MsgBox "done"

End Su

 

[Gordon]

Hi...the code crashes on...

Sub FileNamer() - highlighted in yellow

and

Do Until FileName$ = "" - FileNames$ is highlighted in grey

Error message says...

Type declration character does not match the correct data type.

Any thoughts...

Thanks so far.

Gordon...