Enregistrer sous avec chemin de dossier partiel

Bonjour à tous,

Je cherche à faire un SaveAs sur un chemin partiellement connu, voici l'arborescence du chemin:

"Z:\Commercial\2 - Commandes\2023\INCONNU\AR999999" ou "Z:\Commercial\2 - Commandes\2023\INCONNU\AR888888" etc. Je connais donc quasiment tout à part un dossier.

J'avais au départ trouvé une solution alternative à mon soucis, qui consistait à chercher un fichier que j'implantais au début dans le dossier "AR" pour pointer ensuite vers le dossier qui contient le fichier, en gros un fichier temporaire que je vise. Mais j'ai plusieurs dizaines de dossiers "INCONNU", qui contiennent des centaines de sous-dossiers contenant des centaines de fichiers, ce qui fait que chercher le fichier pointeur prends plusieurs minutes...

Je cherche donc de nouveau à trouver le Dossier "AR" sans connaitre le nom du dossier "INCONNU" ce qui me permettrait de passe d'une revue de plusieurs milliers de fichiers à une revue de quelques dizaines de dossiers.

Voici le code qui cherchait le fichier pointeur, je ne sais pas s'il est adaptable pour de la recherche de dossier, ces fonctions Fso me dépassent un peu.

Option Explicit
Sub Recherche_Dossier()

    'Déclaration des variables
    Dim Lien_Fichier As String
    Dim Répertoire As String
    Dim Fso As Object
    Dim Dossier_Départ As Object
    Dim Lien_Dossier As Variant

    ValeurRecherche = 0

    'Définition des objects
    Set Fso = CreateObject("Scripting.FilesystemObject")

    'Choix du répertoire de départ
    Répertoire = "Z:\Commercial\2 - Commandes\" & Year(Date) & "\"

    'Recherche des fichiers
    Set Dossier_Départ = Fso.GetFolder(Répertoire)
    Lien_Fichier = Empty
    Recherche_Fichier Fso, Dossier_Départ, Nom_Fichier, Lien_Fichier
    If Lien_Fichier = Empty Then
        Recherche_Fichier Fso, Dossier_Départ, Nom_Fichier2, Lien_Fichier
        If Lien_Fichier = Empty Then
            Wait.Hide
Lien:
            Lien_Dossier = Application.InputBox("Dossier non trouvé. Veuillez entrer le lien manuellement." & vbCr _
            & vbCr _
            & "Exemple:" & vbCr _
            & vbCr _
            & " Z:\Commercial\2 - Commandes\2023\Solvay\AR055252" & vbCr _
            & vbCr _
            & "", "Saisie manuelle du lien")
            If Lien_Dossier = False Then
                ValeurRecherche = 1
                Unload Wait
            Else
                If Lien_Dossier = "" Then
                    MsgBox "Le lien doit être renseigné."
                    GoTo Lien
                Else
                    Annexe.Range("D1") = Lien_Dossier & "\"
                End If
            End If
        Else
            ValeurRecherche = 2
            Annexe.Range("D1") = Left(Lien_Fichier, Len(Lien_Fichier) - 34)
        End If
    Else
        Annexe.Range("D1") = Left(Lien_Fichier, Len(Lien_Fichier) - 96)
    End If

    'Réinitialisation des objets
    Set Fso = Nothing

End Sub
Sub Recherche_Fichier(Fso As Object, Dossier As Object, Nom1 As String, Nom2 As String)

    'Déclaration des variables
    Dim Sous_Dossier As Object
    Dim Fichier As Object
    Dim Nom As String
    Dim Extension_Fichier As String

    'Recherche fichiers
    For Each Fichier In Dossier.Files
        Extension_Fichier = Fso.GetExtensionName(Fichier.Path)
        If Nom1 = Fichier.Name Then Nom2 = Fichier.Path: Exit For
        Nom = Replace(Fichier.Name, "." & Extension_Fichier, "") 'supprime l'extension du nom
        If Nom = Nom1 Then Nom2 = Fichier.Path: Exit For
    Next Fichier

    'Recherche sous-dossier
    For Each Sous_Dossier In Dossier.SubFolders
        If Nom2 <> Empty Then Exit For
        If Sous_Dossier.Attributes = vbDirectory + vbSystem + vbHidden Then Exit For
        Recherche_Fichier Fso, Sous_Dossier, Nom1, Nom2
    Next

End Sub

Merci pour votre aide.

Bonjour, sauf si vous pouvez déterminer une logique à l'appellation du répertoire "INCONNU" je ne vois pas comment faire autrement que la recherche que vous avez.

Les dossiers inconnus sont des noms de client donc aucune logique.

Ne peut-on pas rechercher le nom d'un sous-sous-dossier dans un chemin ? Ou lister tous les sous-dossiers avec DIR et vérifier si le dossier AR999999 est dedans pour récupérer le chemin ?

Bon après deux jours de recherche complet j'ai trouvé un code approchant mon idée. Ce code est bien plus rapide, 45s pour mon code contre 25s avec ce nouveau code, ce qui vu le programme et sa fréquence d'utilisation est énorme pour moi. Le soucis que j'ai c'est que ce code est pas tout à fait ce que je veux faire, il va scanner tous les sous dossiers sans exception pour compter le nombre de fois qu'il rencontre le fichier. Dans mon cas, le fichier sera toujours unique, impossible qu'il existe deux fois, j'aimerai donc que le code stoppe la recherche dès qu'il en a trouvé un mais franchement le code me dépasse un peu Quelqu'un pourrait-il m'aider sur le sujet afin que le code s’arrête au premier fichier trouvé ?

Voici le code en question:

Sub Chercher()
  Dim NbRep As Long, NbFichiers As Long, Nombre As Long, NbBytes As Currency
  Dim Depart As String, Extension As String
  Depart = Range("A3")
  'Extension = Range("A1") & "*.docx"
  NbBytes = TrouveFichiers(Depart, Extension, NbRep, NbFichiers, Nombre)
  If NbBytes = "0" Then
    MsgBox "Aucun fichier trouvé"
  Else
    MsgBox Str(NbFichiers) & " Fichiers trouvés ", vbInformation
  End If
End Sub
Private Function TrouveFichiers(ByVal sFol As String, sFile As String, NbRep As Long, NbFichiers As Long, Nombre As Long) As Currency
Dim tFld, NomFichier As String
  Set fso = CreateObject("Scripting.FileSystemObject")
  On Error GoTo Catch
  Set fld = fso.GetFolder(sFol)
  NomFichier = Dir(fso.BuildPath(fld.Path, sFile), vbNormal Or vbHidden Or vbSystem Or vbReadOnly)
  While Len(NomFichier) <> 0
    TrouveFichiers = TrouveFichiers + FileLen(fso.BuildPath(fld.Path, NomFichier))
    NbFichiers = NbFichiers + 1
    Nombre = Nombre + 1
    Range("B" & Nombre) = fso.BuildPath(fld.ShortPath, NomFichier)
    NomFichier = Dir()
    DoEvents
  Wend
  NbRep = NbRep + 1
  If fld.SubFolders.Count > 0 Then
    For Each tFld In fld.SubFolders
      DoEvents
      TrouveFichiers = TrouveFichiers + TrouveFichiers(tFld.Path, sFile, NbRep, NbFichiers, Nombre)
    Next
  End If
  Exit Function
Catch:     NomFichier = ""
  Resume Next
End Function

Merci.

Réponse trouvée en me posant 5 minutes, il suffisait de quitter la boucle For Each quand le Nombre de fichier était égal à 1. Le dernier code est quand même bien plus rapide que le premier c'est top.