FileSearch Macro (Getting error. Need help)

[Slomaro2000]

All,
I need some help figuring out how to fix this problem.


I have this posted on anther board but its been a while and I still have the error. I have been trying to fix it myself but not having much luck.

Original posted here:
http://www.excelforum.com/excel-programming/655202-move-file-to-folder-based-on-name.html



This macro seems to run fine. But it errors out only when the file name is almost the same.
For example, if I have files:
702
702p
702s
702sw
It will error out.
Error:

Run-time error'1004':
'C:\Docutment and Settings\u369875\Desktop\Project stuff\Testin Save_As\702_2008-November.xls' could not be found. Check the spelling of the file name, and verify that the file location is correct.
If you are trying to open the file from your list of most recently used files o the file menu, make sure that the file has not been renamed, moved or deleted.

This is where it errors

For i = 1 To .FoundFiles.Count
Set wkbk = Workbooks.Open(.FoundFiles(i))

Error is on the Set wkbk line.

What could that be?

This is the error message

This is the error
Run-time error'1004':
'C:\Docutment and Settings\u369875\Desktop\Project stuff\Testin Save_As\146_2008-November.xls' could not be found. Check the spelling of the file name, and verify that the file location is correct.

If you are trying to open the file from your list of most recently used files o the file menu, make sure that the file has not been renamed, moved or deleted.

When I debug it seems that

Set wkbk = Workbooks.Open(.FoundFiles(i))

is finding a different file than

myfile = Dir(mypath & Application.PathSeparator & "*.xls")

So I am guessing I have a problem with the "myfile"

Also I was told to not use the "filesearch" and to use DIR becasue of excel 2007. But I am pretty new at this and don't know how.




Here is the Macro (Its a main macro that calls 3 others)

Sub x()
Application.ScreenUpdating = False
Dim response As Long
    response = MsgBox(prompt:="Are you sure you want to Convert/Format all of Excel files in the folder?", Buttons:=4)
    If response = 7 Then Exit Sub
    
With Application.FileSearch
.LookIn = "C:\Documents and Settings\u369875\Desktop\Project stuff\Testin Save_AS"
.Filename = ".xls"
'.SearchSubFolders = False
.FileType = msoFileTypeExcelWorkbooks
If .Execute() > 0 Then
Set newwkbk = ActiveWorkbook
For i = 1 To .FoundFiles.Count
Set wkbk = Workbooks.Open(.FoundFiles(i))

Call Macro2
Call Macro3
Call Save_To_Directory

Application.StatusBar = "workbook " & i & "  of " & .FoundFiles.Count
Next i
End If
End With
MsgBox "All files have been Formatted"
End Sub

Macro2

Sub Macro2()
    Selection.ClearOutline
    Sheets.Add
    Range("G1").Select
    ActiveCell.FormulaR1C1 = "Everything looked good."
    Range("G2").Select
    ActiveCell.FormulaR1C1 = "Oil Was added."
    Range("G3").Select
    ActiveCell.FormulaR1C1 = "Equipment down, not serviced."
    Range("G4").Select
    ActiveCell.FormulaR1C1 = "Not serviced."
    Range("G5").Select
    ActiveCell.FormulaR1C1 = "Repair needed, add work order."
    Range("G1").Select
    Columns("G:G").EntireColumn.AutoFit
    Sheets("Query1").Select
    Range("Q4").Select
    With Selection.Validation
        .Delete
        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
        xlBetween, Formula1:="=INDIRECT(""SHEET1!G1:G5"")"
        .IgnoreBlank = True
        .InCellDropdown = True
        .InputTitle = ""
        .ErrorTitle = "Error: Must pick from list."
        .InputMessage = _
        "Please choose from the list.  If nothing in this list works type in the next column to the right."
        .ErrorMessage = _
        "Press Cancel and pick from list or press Cancel and type in the next 2 columns."
        .ShowInput = True
        .ShowError = True
    End With
    Range("Q4").Select
    Selection.Copy
    Range("Q5").Select
    Range(Selection, Selection.End(xlDown)).Select
    ActiveSheet.Paste
    Range("Q4").Select
    Application.CutCopyMode = False
    Range("R4").Select
    With Selection.Validation
        .Delete
        .Add Type:=xlValidateTextLength, AlertStyle:=xlValidAlertStop, _
        Operator:=xlLessEqual, Formula1:="40"
        .IgnoreBlank = True
        .InCellDropdown = True
        .InputTitle = ""
        .ErrorTitle = ""
        .InputMessage = _
        "Only allowed 40 charecters per cell.  If more are needed please type them in the cells to the right."
        .ErrorMessage = _
        "Only allowed 40 characters per cell.  If more are needed please type them into the cells to the right."
        .ShowInput = True
        .ShowError = True
    End With
    Selection.Copy
    Range("R5").Select
    Range(Selection, Selection.End(xlDown)).Select
    ActiveSheet.Paste
    Range("S4").Select
    Application.CutCopyMode = False
    With Selection.Validation
        .Delete
        .Add Type:=xlValidateTextLength, AlertStyle:=xlValidAlertStop, _
        Operator:=xlLessEqual, Formula1:="40"
        .IgnoreBlank = True
        .InCellDropdown = True
        .InputTitle = ""
        .ErrorTitle = ""
        .InputMessage = "Only allowed 40 characters per cell"
        .ErrorMessage = "Only allowed 40 characters per cell."
        .ShowInput = True
        .ShowError = True
    End With
    Selection.Copy
    Range("S5").Select
    Range(Selection, Selection.End(xlDown)).Select
    ActiveSheet.Paste
    Range("S4").Select
    Application.CutCopyMode = False
    Range("A1:T1").Select
    With Selection.Interior
        .ColorIndex = 35
        .Pattern = xlSolid
    End With
    Range("A2").Select
End Sub

Macro3

Sub Macro3()
    ActiveWorkbook.Save
    ActiveWorkbook.Close
    
End Sub

Save_To_Directory

Sub Save_To_Directory()
'your path
Const mypath As String = _
    "C:\Documents and Settings\u369875\Desktop\Project stuff\Testin Save_AS"
    
    
Const dest_path As String = _
    "c:\Documents and Settings\u369875\Desktop\Project stuff\Testin Save_AS\All Buildings\MIOM Plants"
 
'the file we are going to save to a certain location
Dim myfile As String
'the directory where you want the file to be saved to
Dim mydir As String
'the workbook
Dim mywb As Workbook
myfile = Dir(mypath & Application.PathSeparator & "*.xls")
Do While myfile <> vbNullString
    mydir = Split(myfile, "_")(0)
    'check if directory exists
    Call CheckDirNames(dest_path, mydir)
    Set mywb = Workbooks.Open(mypath & Application.PathSeparator & myfile)
    
    'save to new location
    mywb.SaveAs dest_path & Application.PathSeparator & mydir & _
                         Application.PathSeparator & myfile
    mywb.Close
    'delete the original file that you saved to the new directory
    Kill mypath & Application.PathSeparator & myfile
    myfile = Dir
Loop
End Sub
Sub CheckDirNames(thedir As String, thesubdir As String)
'check if rootdirectory exists
If Dir(thedir, vbDirectory) = "" Then
    MkDir thedir
'if rootdirectory doesn't exists, already create the subdir
'because subdir can't be present without root dir
    MkDir thedir & Application.PathSeparator & thesubdir
ElseIf Dir(thedir & Application.PathSeparator & thesubdir, vbDirectory) = "" Then
'if rootdirectory exists, create subdir if it's not present
        MkDir thedir & Application.PathSeparator & thesubdir
    End If
End Sub

Man, thats a long post.. Anyhelp would be GREAT!!


Thanks, Jayson

 

[Slomaro2000]

Solved

I added a Global Varible. I will mark the things changed below in RED.

Thanks to everyone that helped me out with this.
Jayson

[B][COLOR="Red"]Global Temp As String[/COLOR][/B]
Sub Macro2()
    Selection.ClearOutline
    Sheets.Add
    Range("G1").Select
    ActiveCell.FormulaR1C1 = "Everything looked good."
    Range("G2").Select
    ActiveCell.FormulaR1C1 = "Oil Was added."
    Range("G3").Select
    ActiveCell.FormulaR1C1 = "Equipment down, not serviced."
    Range("G4").Select
    ActiveCell.FormulaR1C1 = "Not serviced."
    Range("G5").Select
    ActiveCell.FormulaR1C1 = "Repair needed, add work order."
    Range("G1").Select
    Columns("G:G").EntireColumn.AutoFit
    Sheets("Query1").Select
    Range("Q4").Select
    With Selection.Validation
        .Delete
        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
        xlBetween, Formula1:="=INDIRECT(""SHEET1!G1:G5"")"
        .IgnoreBlank = True
        .InCellDropdown = True
        .InputTitle = ""
        .ErrorTitle = "Error: Must pick from list."
        .InputMessage = _
        "Please choose from the list.  If nothing in this list works type in the next column to the right."
        .ErrorMessage = _
        "Press Cancel and pick from list or press Cancel and type in the next 2 columns."
        .ShowInput = True
        .ShowError = True
    End With
    Range("Q4").Select
    Selection.Copy
    Range("Q5").Select
    Range(Selection, Selection.End(xlDown)).Select
    ActiveSheet.Paste
    Range("Q4").Select
    Application.CutCopyMode = False
    Range("R4").Select
    With Selection.Validation
        .Delete
        .Add Type:=xlValidateTextLength, AlertStyle:=xlValidAlertStop, _
        Operator:=xlLessEqual, Formula1:="40"
        .IgnoreBlank = True
        .InCellDropdown = True
        .InputTitle = ""
        .ErrorTitle = ""
        .InputMessage = _
        "Only allowed 40 charecters per cell.  If more are needed please type them in the cells to the right."
        .ErrorMessage = _
        "Only allowed 40 characters per cell.  If more are needed please type them into the cells to the right."
        .ShowInput = True
        .ShowError = True
    End With
    Selection.Copy
    Range("R5").Select
    Range(Selection, Selection.End(xlDown)).Select
    ActiveSheet.Paste
    Range("S4").Select
    Application.CutCopyMode = False
    With Selection.Validation
        .Delete
        .Add Type:=xlValidateTextLength, AlertStyle:=xlValidAlertStop, _
        Operator:=xlLessEqual, Formula1:="40"
        .IgnoreBlank = True
        .InCellDropdown = True
        .InputTitle = ""
        .ErrorTitle = ""
        .InputMessage = "Only allowed 40 characters per cell"
        .ErrorMessage = "Only allowed 40 characters per cell."
        .ShowInput = True
        .ShowError = True
    End With
    Selection.Copy
    Range("S5").Select
    Range(Selection, Selection.End(xlDown)).Select
    ActiveSheet.Paste
    Range("S4").Select
    Application.CutCopyMode = False
    Range("A1:T1").Select
    With Selection.Interior
        .ColorIndex = 35
        .Pattern = xlSolid
    End With
    Range("A2").Select
End Sub
Sub Macro3()
    ActiveWorkbook.Save
    ActiveWorkbook.Close
    
End Sub
 
Sub x()
Application.ScreenUpdating = False
Dim response As Long
    response = MsgBox(prompt:="Are you sure you want to Convert/Format all of Excel files in the folder?", Buttons:=4)
    If response = 7 Then Exit Sub
    
With Application.FileSearch
.LookIn = "C:\Documents and Settings\u369875\Desktop\Project stuff\Testin Save_AS"
.Filename = ".xls"
'.SearchSubFolders = False
.FileType = msoFileTypeExcelWorkbooks
If .Execute() > 0 Then
Set newwkbk = ActiveWorkbook
For i = 1 To .FoundFiles.Count
Set wkbk = Workbooks.Open(.FoundFiles(i))
[B][COLOR="Red"]Temp = wkbk.Name[/COLOR][/B]
Call Macro2
Call Macro3
Call Save_To_Directory

Application.StatusBar = "workbook " & i & "  of " & .FoundFiles.Count
Next i
End If
End With

MsgBox "All files have been Formatted"
End Sub

Sub Save_To_Directory()
'your path
Const mypath As String = _
    "C:\Documents and Settings\u369875\Desktop\Project stuff\Testin Save_AS"
    
    
Const dest_path As String = _
    "c:\Documents and Settings\u369875\Desktop\Project stuff\Testin Save_AS\All Buildings\MIOM Plants"
 
'the file we are going to save to a certain location
Dim myfile As String
'the directory where you want the file to be saved to
Dim mydir As String
'the workbook
Dim mywb As Workbook
myfile = Dir(mypath & Application.PathSeparator & [B][COLOR="Red"]Temp[/COLOR][/B])
Do While myfile <> vbNullString
    mydir = Split(myfile, "_")(0)
    'check if directory exists
    Call CheckDirNames(dest_path, mydir)
    Set mywb = Workbooks.Open(mypath & Application.PathSeparator & myfile)
    
    'save to new location
    mywb.SaveAs dest_path & Application.PathSeparator & mydir & _
                         Application.PathSeparator & myfile
    mywb.Close
    'delete the original file that you saved to the new directory
    Kill mypath & Application.PathSeparator & myfile
    myfile = Dir
Loop
End Sub
Sub CheckDirNames(thedir As String, thesubdir As String)
'check if rootdirectory exists
If Dir(thedir, vbDirectory) = "" Then
    MkDir thedir
'if rootdirectory doesn't exists, already create the subdir
'because subdir can't be present without root dir
    MkDir thedir & Application.PathSeparator & thesubdir
ElseIf Dir(thedir & Application.PathSeparator & thesubdir, vbDirectory) = "" Then
'if rootdirectory exists, create subdir if it's not present
        MkDir thedir & Application.PathSeparator & thesubdir
    End If
End Sub