HELP - Code not working (My old boss has retired and this was his code)
My old boss has retired and I had a document cotrol sheet that opened files (any format including PDF's) from folders with the same name as the tab. since i have now been forced to use excel 2013 it does not work. Please can someone help me!!! The code is below: (I think it is somthing to do with appliation.filesearch!!!
Code:
Public myFile, mylist()
Sub Open_File()
'
' Macro1 Macro
' Macro recorded 05/11/2010 by bc
'
Dim myStart As Integer, myLength As Integer, myTab
myFile = Cells(ActiveCell.Row, 1).Value
myTab = "\" & ActiveSheet.Name
myLength = 0
myStart = Len(myFile) - 3
If InStr(myStart, myFile, ".", vbBinaryCompare) = 0 Then
myStart = Len(Cells(ActiveCell.Row, 1).Value)
Else
myStart = myStart - 1
End If
For i = 1 To 5
myLength = InStr(myLength + 1, myFile, "-", vbBinaryCompare)
Next i
myLength = myLength + 7 'length of File name containing a string of type ??-???-??-???-???-???????
With Application.FileSearch
ReSearchLine:
.NewSearch
.LookIn = ActiveWorkbook.Path & myTab
.Filename = "*" & Left(myFile, myLength) & "*.*"
.Execute
If .FoundFiles.Count = 0 Then
myTab = MsgBox("File " & myFile & " has not been saved in the '" & myTab & "' sub-folder." & Chr(13) & Chr(13) & _
"Do you want to search in another sub-folder?", vbYesNo)
If myTab = vbNo Then
Exit Sub
Else
myTab = "\" & InputBox("Insert the sub-folder name.")
GoTo ReSearchLine
End If
End If
If .FoundFiles.Count = 1 Then
myFile = .FoundFiles(1)
ElseIf myStart > myLength Then
myLength = myStart
GoTo ReSearchLine
Else
ReDim mylist(.FoundFiles.Count)
mylist(0) = .FoundFiles.Count
For i = 1 To .FoundFiles.Count
mylist(i) = Right(.FoundFiles(i), Len(.FoundFiles(i)) - Len(ActiveWorkbook.Path) - 1)
'MsgBox (myList(0) & " simailar files found." & Chr(10) & i & ". - " & myList(i))
Next i
UserForm1.Show
If myFile = "None Selected" Then
MsgBox "No File for opening was selected - Macro Ending."
Exit Sub
ElseIf myFile = "Exit" Then
MsgBox "Macro Terminated."
Exit Sub
End If
myFile = ActiveWorkbook.Path & "\" & myFile
End If
End With
ActiveWorkbook.FollowHyperlink Address:=myFile, NewWindow:=True
'ActiveWorkbook.FollowHyperlink Address:=myFile, NewWindow:=True
End Sub
Sub Open_Active_Cell_File()
'
' Macro1 Macro
' Macro recorded 05/11/2010 by bc
'
Dim myStart As Integer, myLength As Integer, myTab
myFile = ActiveCell.Value
myTab = "\" & ActiveSheet.Name
myLength = 0
myStart = Len(myFile) - 3
If InStr(myStart, myFile, ".", vbBinaryCompare) = 0 Then
myStart = Len(Cells(ActiveCell.Row, 1).Value)
Else
myStart = myStart - 1
End If
For i = 1 To 5
myLength = InStr(myLength + 1, myFile, "-", vbBinaryCompare)
Next i
myLength = myLength + 7 'length of File name containing a string of type ??-???-??-???-???-???????
With Application.FileSearch
ReSearchLine:
.NewSearch
.LookIn = ActiveWorkbook.Path & myTab
.Filename = "*" & Left(myFile, myLength) & "*.*"
.Execute
If .FoundFiles.Count = 0 Then
myTab = MsgBox("File " & myFile & " has not been saved in the '" & myTab & "' sub-folder." & Chr(13) & Chr(13) & _
"Do you want to search in another sub-folder?", vbYesNo)
If myTab = vbNo Then
Exit Sub
Else
myTab = "\" & InputBox("Insert the sub-folder name.")
GoTo ReSearchLine
End If
End If
If .FoundFiles.Count = 1 Then
myFile = .FoundFiles(1)
ElseIf myStart > myLength Then
myLength = myStart
GoTo ReSearchLine
Else
ReDim mylist(.FoundFiles.Count)
mylist(0) = .FoundFiles.Count
For i = 1 To .FoundFiles.Count
mylist(i) = Right(.FoundFiles(i), Len(.FoundFiles(i)) - Len(ActiveWorkbook.Path) - 1)
'MsgBox (myList(0) & " simailar files found." & Chr(10) & i & ". - " & myList(i))
Next i
UserForm1.Show
If myFile = "None Selected" Then
MsgBox "No File for opening was selected - Macro Ending."
Exit Sub
ElseIf myFile = "Exit" Then
MsgBox "Macro Terminated."
Exit Sub
End If
myFile = ActiveWorkbook.Path & "\" & myFile
End If
End With
ActiveWorkbook.FollowHyperlink Address:=myFile, NewWindow:=True
'ActiveWorkbook.FollowHyperlink Address:=myFile, NewWindow:=True
End Sub
Sub Open_Lifting_Plan()
Dim myStart As Integer, myLength As Integer, myTab
myFile = Cells(ActiveCell.Row, 1).Value
myTab = "\" & Cells(ActiveCell.Row, 2).Value
'myLength = 0
'myStart = Len(myFile) - 3
'If InStr(myStart, myFile, ".", vbBinaryCompare) = 0 Then
'myStart = Len(Cells(ActiveCell.Row, 1).Value)
'Else
'myStart = myStart - 1
'End If
'For i = 1 To 5
'myLength = InStr(myLength + 1, myFile, "-", vbBinaryCompare)
'Next i
'myLength = myLength + 7 'length of File name containing a string of type ??-???-??-???-???-???????
With Application.FileSearch
ReSearchLine:
.NewSearch
.LookIn = "K:\LondonDLR3rdCar" & myTab
.Filename = myFile
.Execute
If .FoundFiles.Count = 0 Then
myTab = MsgBox("File:- '" & myFile & "' has not been found in the '" & myTab & "' sub-folder.", vbOKOnly)
'If myTab = vbNo Then
Exit Sub
'Else
'myTab = "\" & InputBox("Insert the sub-folder name.")
'GoTo ReSearchLine
'End If
End If
'If .FoundFiles.Count = 1 Then
' myFile = .FoundFiles(1)
'ElseIf myStart > myLength Then
'myLength = myStart
'GoTo ReSearchLine
'Else
' ReDim mylist(.FoundFiles.Count)
' mylist(0) = .FoundFiles.Count
' For i = 1 To .FoundFiles.Count
'mylist(i) = Right(.FoundFiles(i), Len(.FoundFiles(i)) - Len(ActiveWorkbook.Path) - 1)
'MsgBox (myList(0) & " simailar files found." & Chr(10) & i & ". - " & myList(i))
'Next i
'UserForm1.Show
'If myFile = "None Selected" Then
' MsgBox "No File for opening was selected - Macro Ending."
' Exit Sub
'ElseIf myFile = "Exit" Then
' MsgBox "Macro Terminated."
' Exit Sub
'End If
myFile = "K:\LondonDLR3rdCar" & myTab & "\" & myFile
'End If
End With
ActiveWorkbook.FollowHyperlink Address:=myFile, NewWindow:=True
'ActiveWorkbook.FollowHyperlink Address:=myFile, NewWindow:=True
End Sub
