Sub InHetFile()
On Error Resume Next
Dim FileS As FileSearch
Dim Wb, Wb1 As Workbook
Dim F As Variant
Application.ScreenUpdating = False
Set Wb = ThisWorkbook
FPath = Wb.Path
Set FileS = Application.FileSearch
With FileS
.NewSearch
.Filename = "*.xls"
.LookIn = Wb.Path
.SearchSubFolders = False
.Execute
End With
For Each F In Application.FileSearch.FoundFiles
If F = Wb.FullName Then GoTo NextFile
Workbooks.Open F
Set Wb1 = Workbooks(Replace(F, Wb.Path & "\", ""))
Wb1.Activate
ActiveWorkbook.PrintOut
Wb1.Close
NextFile:
Next F
Application.ScreenUpdating = True
End Sub
