XL 2019 Compter le nb de Fichier dans un dossier afin de créer une nouvelle version

[youguybass]

Bonjour à tous
Je cherche à compter dans un dossier, le nb de fichier qui aurait les 12 premiers caractères identiques à une variable "NumCom" par exemple
Dans le dossier (en image) ci-dessous en exemple je voudrais que si je faisait une nouvelle version de la OUT 2027-016, celle-ci soit appelée OUT 2027-016 _ SNM Métal _ Version 6
Que si je créé une nouvelle commande OUT 2027-019 _ ToTo , cela me crée comme fichier OUT 2027-019 _ ToTo _ Version 1

D'avance merci

Sub CréatPDFCommande()
Dim NumCom As String, DosDépot As String, DosRacine As String, An%, Fournisseur, Indice

Fournisseur = Page17_2Commandes.ComboBox1

NumCom = TextBox26       ' Num Commande
An = Left(Split(NumCom, " ")(1), 4) 'Récupère l'année de la commande

DosRacine = "I:\Chevalerias\" ' // Peut-être à adapter
DosDépot = "Commandes " & An        ' // Nom du dossier de dépot voulu
Indice = 1

'***************************
'On Error Resume Next: ChDrive DosRacine: ChDir DosRacine & DosDépot
'If Err Then MkDir DosRacine & DosDépot: ChDir DosRacine & DosDépot

'Ci-dessus ou ci-dessous les 2 fonctionnent

Dim cheminDossier As String
cheminDossier = DosRacine & "\" & DosDépot  ' Assure le \ entre les deux

If Dir(cheminDossier, vbDirectory) = "" Then
    MkDir cheminDossier
End If
'*********************************

Dim CheminCommande As String
CheminCommande = cheminDossier & "\" & NumCom & " _ " & Fournisseur & " _ Version " & Indice & ".pdf"
'Indice = Left(Split(CheminCommande, " ")(1), 4)
Indice = Right(Split(CheminCommande, " ")(1), 1)

MsgBox Indice

If Dir(CheminCommande, vbDirectory) <> "" Then
    If MsgBox("Le PDF de cette commande existe déja" & Chr(10) & "Voulez vous l'écraser? ", vbYesNo + vbExclamation) = vbYes Then

        ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=DosRacine & DosDépot & "\" & NumCom & " _ " & Fournisseur & " _ Version " & Indice & ".pdf", Quality:=xlQualityStandard, _
        IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=True
    Else
    
  If MsgBox("Voulez vous faire évoluer l'indice" & Chr(10) & "Blabla", vbYesNo + vbExclamation) = vbYes Then
    Indice = Indice + 1
    
    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=DosRacine & DosDépot & "\" & NumCom & " _ " & Fournisseur & " _ Version " & Indice & ".pdf", Quality:=xlQualityStandard, _
        IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=True
        Else: Exit Sub
        End If
    
    End If
 
    Else 'Pour créer les PDF s'il n'existe pas
    Indice = 1
        ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=DosRacine & DosDépot & "\" & NumCom & " _ " & Fournisseur & " _ Version " & Indice & ".pdf", Quality:=xlQualityStandard, _
        IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=True
 
End If

    End Sub

 

[fanch55]

Bonjour,
Code spécifique à votre demande, je pense que cela devrait fonctionner également avec des dossiers réseau :

Sub CréatPDFCommande()
    Dim NumCom As String, DosDépot As String, DosRacine As String, An%, Fournisseur, Indice
    Dim cheminDossier As String
    Dim Target As String, Base As String
   
    Fournisseur = "SNM Métal"           ' Fournisseur = Page17_2Commandes.ComboBox1
    NumCom = "OUT 2027-016"             ' NumCom = TextBox26        ' Num Commande
    An = Left(Split(NumCom, " ")(1), 4) 'Récupère l'année de la commande
   
    DosRacine = "O:\Chevalerias"        ' Peut-être à adapter
    If Dir(DosRacine, vbDirectory) = "" Then MkDir DosRacine
   
    DosDépot = "Commandes " & An        ' Nom du dossier de dépot voulu
       
    cheminDossier = DosRacine & "\" & DosDépot  ' Assure le \ entre les deux
    If Dir(cheminDossier, vbDirectory) = "" Then MkDir cheminDossier
   
    Base = cheminDossier & "\" & NumCom & " _ " & Fournisseur & " _ Version "
    Indice = Next_Version(Base)
    If Not IsEmpty(Indice) _
    Then ActiveSheet.ExportAsFixedFormat _
            Filename:=Base & Indice & ".pdf", _
            Type:=xlTypePDF, OpenAfterPublish:=False
           
End Sub
Function Next_Version(Target As String) As Variant
    T = Split(Target, "\")
    Extension = "Pdf"
    Drive = T(0): T(0) = ""
    FileToSearch = T(UBound(T)) & "%": T(UBound(T)) = ""
    Path = Join(T, "\\")

    Sql = "Select * from CIM_DataFile" _
        & " where Hidden=False" _
        & "   and Extension='" & Extension & "'" _
        & "   and Drive='" & Drive & "'" _
        & "   and Path='" & Path & "'" _
        & "   and Filename like '" & FileToSearch & "'"
    
    Set WMIService = GetObject("winmgmts:" & "!\\.\root\cimv2")
        Set ListFiles = WMIService.ExecQuery(Sql)
        On Error GoTo Error_Exit
        For Each File In ListFiles
            T = Split(File.Filename)
            If Val(T(UBound(T))) = T(UBound(T)) Then
                Next_Version = Application.Max(Next_Version, T(UBound(T)))
            Else
                Err.Raise 600, "Next_Version", _
                    T(UBound(T)) & " est inattendu en fin du fichier" & vbLf & File.Filename
            End If
        Next
    Set WMIService = Nothing
    Next_Version = Next_Version + 1

Error_Exit:
    If Err Then MsgBox Err.Description, vbCritical
End Function

 

[youguybass]

Bonjour et merci pour vos recherches
J'ai testé, cela fonctionne avec quelques ajustement à mon fichier.

Merci