Søge mapper efter .xls

'---
' Procedure : ShowSubFolderList
' Author : Orange
' Date : 1/22/2009
' Purpose : Subroutine that works with ShowFolderList. This gets the folder
' and file name.
' Calls: ShowSubFolderList (recursive)
' CalledBy: ShowFolderList
'-
'
Sub ShowSubFolderList(fld As Object, ByRef str As String)
Dim fil As Object, subfld As Object, arr() As Variant

For Each fil In fld.Files

str = str & fld.Name & "|" & fil.Name & "^"

Next fil

For Each subfld In fld.SubFolders
Call ShowSubFolderList(subfld, str)
Next subfld

Set fil = Nothing
Set subfld = Nothing

End Sub

Sub SrchForFiles()
        Dim i As Long, z As Long, Rw As Long
    Dim ws As Worksheet
    Dim y As Variant
    Dim fLdr As String, fil As String, FPath As String
    Dim MyTempList As String
    Dim lfldrnm As Integer
    Dim FldrName As String
    Dim FilName As String
    Dim sTmp As String
   
    y = "case.xls"
    Application.ScreenUpdating = False
    '**********************************************************************
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Show
        fLdr = .SelectedItems(1)
    End With
    '**********************************************************************
    With Application.FileSearch
        .NewSearch
        .LookIn = fLdr
        .SearchSubFolders = True
        .Filename = y
     
      On Error GoTo 0
        If .Execute() > 0 Then
            For i = 1 To .FoundFiles.Count
                fil = .FoundFiles(i)
                    'Get file path from file name
                FPath = Left(fil, Len(fil) - Len(Split(fil, "\")(UBound(Split(fil, "\")))) - 1)
                Workbooks.Open Filename:=fil
                Sheets("Start").Select
                'FldrName = FolderName
                Sheets("Start").Copy After:=Workbooks("Opsamlingssheet.xls").Sheets(1)
                'ActiveSheet.Name = FldrName
                Windows("case.xls").Close (True)
                                     
                'FPath = Left(fil, Len(fil) - Len(Split(fil, "\")(UBound(Split(fil, "\")))) - 1)
               
            Next i
        End If
    End With
   
     
    Exit Sub

End Sub

Ups der kom lige ldit for meget med

Sub SrchForFiles()
        Dim i As Long, z As Long, Rw As Long
    Dim ws As Worksheet
    Dim y As Variant
    Dim fLdr As String, fil As String, FPath As String
    Dim MyTempList As String
    Dim lfldrnm As Integer
    Dim FldrName As String
    Dim FilName As String
    Dim sTmp As String
   
    y = "case.xls"
    Application.ScreenUpdating = False
    '**********************************************************************
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Show
        fLdr = .SelectedItems(1)
    End With
    '**********************************************************************
    With Application.FileSearch
        .NewSearch
        .LookIn = fLdr
        .SearchSubFolders = True
        .Filename = y
     
      On Error GoTo 0
        If .Execute() > 0 Then
            For i = 1 To .FoundFiles.Count
                fil = .FoundFiles(i)
                    'Get file path from file name
                FPath = Left(fil, Len(fil) - Len(Split(fil, "\")(UBound(Split(fil, "\")))) - 1)
                Workbooks.Open Filename:=fil
                Sheets("Start").Select
                'FldrName = FolderName
                Sheets("Start").Copy After:=Workbooks("Opsamlingssheet.xls").Sheets(1)
                'ActiveSheet.Name = FldrName
                Windows("case.xls").Close (True)
                                     
                'FPath = Left(fil, Len(fil) - Len(Split(fil, "\")(UBound(Split(fil, "\")))) - 1)
               
            Next i
        End If
    End With
   
     
    Exit Sub

End Sub