Home |
Search |
Today's Posts |
#1
Posted to microsoft.public.excel.programming
|
|||
|
|||
Why won't this work
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 |
#2
Posted to microsoft.public.excel.programming
|
|||
|
|||
Why won't this work
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 -- Kaak ------------------------------------------------------------------------ Kaak's Profile: http://www.excelforum.com/member.php...fo&userid=7513 View this thread: http://www.excelforum.com/showthread...hreadid=566599 |
#3
Posted to microsoft.public.excel.programming
|
|||
|
|||
Why won't this work
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... "Kaak" wrote: 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 DIFFERENT 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 Sub -- Kaak ------------------------------------------------------------------------ Kaak's Profile: http://www.excelforum.com/member.php...fo&userid=7513 View this thread: http://www.excelforum.com/showthread...hreadid=566599 |
Reply |
Thread Tools | Search this Thread |
Display Modes | |
|
|
Similar Threads | ||||
Thread | Forum | |||
how can i automatically generate work order numbers from work orde | Excel Discussion (Misc queries) | |||
flash object dont work in my excel work sheet | Excel Discussion (Misc queries) | |||
If I have a work sheet protected and try to run a macro to hide rows or columns it won't work. Correct? | Excel Programming | |||
Counting dates in multiple work sheets and work books | Excel Discussion (Misc queries) | |||
Is there away to keep "auto save" from jumping to the first work sheet in the work book? | New Users to Excel |