Sub Выбрать_картинку()

    Dim colFolders As New Collection, colFiles As New Collection
    Dim lngRnd As Long, i As Long
    
    Call GetFolders(ThisWorkbook.Path & "\Картинки", colFolders)
    
    For i = 1 To colFolders.Count
        Call GetFiles(colFolders(i), colFiles)
    Next i
    
    Randomize
    lngRnd = Int((colFiles.Count - 1 + 1) * Rnd + 1)
    ActiveSheet.Image1.Picture = LoadPicture(colFiles(lngRnd))

End Sub

Private Sub GetFolders(strParentFolder As String, colFolders As Collection)
    
    Dim strFolderName As String
    Dim col As New Collection, i As Long
    
    strFolderName = Dir(strParentFolder & "\", vbDirectory)
    Do While strFolderName <> ""
        If (GetAttr(strParentFolder & "\" & strFolderName) And vbDirectory) <> 0 Then
            If strFolderName <> "." And strFolderName <> ".." Then
                col.Add Item:=strParentFolder & "\" & strFolderName
            End If
        End If
        strFolderName = Dir
    Loop
    
    For i = 1 To col.Count
        colFolders.Add Item:=col(i)
    Next i
    
    For i = 1 To col.Count
        Call GetFolders(col(i), colFolders)
    Next i

End Sub

Private Sub GetFiles(strFolderName As String, colFiles As Collection)
    Dim strFileName As String
    strFileName = Dir(strFolderName & "\")
    Do While strFileName <> ""
        colFiles.Add Item:=strFolderName & "\" & strFileName
        strFileName = Dir
    Loop
End Sub