Office: (Office 2016) Nach Bildern im Unterordner suchen

Guten Morgen,

ich habe folgenden Code, um nach Bildern mit bestimmtem Namen in einem Ordner zu suchen. Das funktioniert aber nur, wenn ich die Bilder direkt in dem Ordner des Workbooks habe. Wie kann ich den Code so verändern, dass er auch in Unterordnern sucht?
Code:

Sub Bildeinfuegen()
Dim rngZiel As Range
Dim strPfad As String
Dim strBild As String

strPfad = ThisWorkbook.Path & ""
strBild = Dir(strPfad & "*" & Range("B29").Value & "*.jpg")
If strBild = "" Then
MsgBox "Es wurde kein Bild gefunden."
Else
Set rngZiel = Range("B26").MergeArea
Application.ScreenUpdating = False
With ActiveSheet.Pictures.Insert(strPfad & strBild).ShapeRange
.LockAspectRatio = True
.Top = rngZiel.Top
.Left = rngZiel.Left
.Height = Application.CentimetersToPoints(8)
End With
Application.ScreenUpdating = True
End If
End Sub

 

Hi,

das kannst du z.B. so lösen:

Code:

Option Explicit
Dim strOrdner As String

Sub Bildeinfuegen()
    Dim rngZiel As Range
    Dim strPfad As String
    Dim strBild As String
    strPfad = ThisWorkbook.Path & ""
    strBild = Dir(strPfad & "*" & Range("B29").Value & "*.jpg")
    If strBild = "" Then
        OrdnerAuswahl strPfad & "\", Range("B29").Value & ".jpg"
    Else
        strOrdner = strPfad
    End If
    If strOrdner <> "" Then
        Set rngZiel = Range("B26").MergeArea
        Application.ScreenUpdating = False
        With ActiveSheet.Pictures.Insert(strOrdner & "\" & Range("B29").Value & ".jpg").ShapeRange
            .LockAspectRatio = True
            .Top = rngZiel.Top
            .Left = rngZiel.Left
            .Height = Application.CentimetersToPoints(8)
        End With
        Application.ScreenUpdating = True
    Else
        MsgBox "Bild " & Range("B29") & " nicht gefunden"
    End If
End Sub

Sub OrdnerAuswahl(varSuchordner, strMappe As String)
   Dim fso As Object
   Dim Ordner
   Dim UnterOrdner
   Dim lngUnterOrdner As Long
   Dim blnVorhanden As Boolean
   Dim objFile As Object
   Dim strName As String
   Dim intSpalte As Integer
   intSpalte = 2
   Set fso = CreateObject("Scripting.FileSystemObject")
   Set Ordner = fso.getfolder(varSuchordner)
   On Error Resume Next
   lngUnterOrdner = Ordner.subfolders.Count
   If lngUnterOrdner <> 0 Then blnVorhanden = True
   On Error GoTo 0
   If blnVorhanden Then
        For Each UnterOrdner In Ordner.subfolders
            If Dir(UnterOrdner & "\" & strMappe) <> "" Then
                strOrdner = UnterOrdner & "\"
                Exit For
            End If
            OrdnerAuswahl UnterOrdner, strMappe
        Next
        blnVorhanden = False
   End If
   Set fso = Nothing
   Set Ordner = Nothing
End Sub

Bis später,
Karin

 

Vielen Dank für die schnelle Lösung.
Gruß
Kurzpeter