Find mappe

Fandt lige denne løsning.

Sub Rektangelafrundedehjørner1_Klik()

Dim mainFolder As String, productCode As String
    Dim dirLines As Variant
    Dim i As Long, foundFile As String
 
    mainFolder = Range("G1")            'change
    productCode = Range("I1")          'change
 
    If Right(mainFolder, 1) <> "\" Then mainFolder = mainFolder & "\"
    dirLines = Split(CreateObject("wscript.shell").exec("cmd /c DIR /B /S /A-D /O-D " & Chr(34) & mainFolder & "*" & productCode & Chr(34)).StdOut.ReadAll, vbCrLf)
 
    foundFile = ""
    If UBound(dirLines) >= 0 Then
        i = 0
        While i < UBound(dirLines) And foundFile = ""
            If InStr(1, dirLines(i), "\Archive\", vbTextCompare) = 0 Then foundFile = dirLines(i)
            i = i + 1
        Wend
    End If
    If foundFile <> "" Then
        'MsgBox "Found " & foundFile, vbInformation, "Find Product workbook"
        ActiveSheet.Range("A1").Value = foundFile
    Else
        MsgBox "Excel workbook with file name containing product code '" & productCode & "' not found in " & mainFolder & " and its subfolders", vbExclamation, "Find Product workbook"
    End If
   
End Sub