[Résolu] VBA XL - regrouper des noms de fichiers commençant par les 10 mêmes caract

[kawaman76]

Bonjour à tous.

J'ai adapté un "code" (à mon niveau) pour récupérer les fichiers contenus dans un dossier. Jusque là pas de soucis. Cela donne:

E236805000__A_A1_1_3.dwg
E236805000__A_A1_2_3.dwg
E236805000__A_A1_3_3.dwg
E236805120___A0_1_1.dwg
E236805121___A0_1_1.dwg
E236805122___A2_1_1.dwg
E236805123___A3_1_1.dwg
E236805124___A3_1_1.dwg
E236805125___A3_1_1.dwg
E236805126___A3_1_1.dwg

Seconde étape, je souhaiterai que tous les fichiers commençant avec les 10 premiers caractères identiques soient regroupés (sur la même ligne et séparés d'un " :" ) sous la forme...

E236805000__A_A1_1_3.dwg:E236805000__A_A1_2_3.dwg:E236805000__A_A1_3_3.dwg
E236805120___A0_1_1.dwg
E236805121___A0_1_1.dwg
E236805122___A2_1_1.dwg
E236805123___A3_1_1.dwg
E236805124___A3_1_1.dwg
E236805125___A3_1_1.dwg
E236805126___A3_1_1.dwg


Voici le code utilisé pour l'heure...

Sub repertorier_fichier()
    Dim Chemin As String, Fichier As String
    
    'indique le répertoire contenant les fichiers
    Chemin = ActiveSheet.Range("A2").Value
    'Boucle sur tous les fichiers msg du répertoire.
    Fichier = Dir(Chemin & "\" & "*.*")

    numligne = 5
    
    Do While Len(Fichier) > 0
        Sheets("LISTAGE NOMS FICHIERS").Range("A" & numligne).Value = Fichier
        numligne = numligne + 1
        Fichier = Dir()
    Loop
End Sub

merci d'avance de votre aide.

 

[Compte Supprimé 979]

Re : VBA XL - regrouper des noms de fichiers commençant par les 10 mêmes caract

Bonjour Kawaman76

Essaye avec ceci

Sub repertorier_fichier()
  Dim LigF As Long, sTmp As String
  Dim Chemin As String, Fichier As String, NumLigne As Long
  Dim Sht As Worksheet
  ' Définir la feuille de travail (plus simple)
  Set Sht = Sheets("LISTAGE NOMS FICHIERS")
  'indique le répertoire contenant les fichiers
  Chemin = ActiveSheet.Range("A2").Value
  'Boucle sur tous les fichiers msg du répertoire.
  Fichier = Dir(Chemin & "\" & "*.*")
  '
  Do While Len(Fichier) > 0
    sTmp = Left(Fichier, 10)  ' 10 premiers caractères
    ' Vérifier si le code n'existe pas déjà
    On Error Resume Next
    LigF = 0
    LigF = Range("A:A").Find(What:=sTmp, LookIn:=xlValues, _
                             LookAt:=xlPart, SearchOrder:=xlByRows, _
                             MatchCase:=False, SearchFormat:=False).Row
    On Error GoTo 0
    ' Si une ligne à été trouvées
    If LigF <> 0 Then
      Sht.Range("A" & LigF).Value = Sht.Range("A" & LigF).Value & ":" & Fichier
    Else
      NumLigne = Sht.Range("A" & Rows.Count).End(xlUp).Row + 1
      Sht.Range("A" & NumLigne).Value = Fichier
    End If
    ' Continuer dans le dir
    Fichier = Dir()
  Loop
End Sub

A+

 

[kawaman76]

Re : VBA XL - regrouper des noms de fichiers commençant par les 10 mêmes caract

Merci BrunoM45. Très rapide réponse, et 100% fonctionnelle. Respect. J'ai un peu tardé à te remercier. Bien plus que toi à me donner la solution Bonne continuation et merci encore.