copier les Fichiers d'un répertoire par ordre alpha

[C@thy]

Bonjour,

je cherche comment copier un par un tous les fichiers d'un répertoire, mais selon l'ordre alpha de leur nom.

Je vous explique le comment du pourquoi de la chose.

En fait, il s'agit de fichiers Word, mais je crois que cela importe peu. Chaque fichier correspond à un thème (que je thème que je thème )...
je les prends un par un et je les copie les uns à la suite des autres,
(dans un même doc. word)
mais là où ça se corse, c'est que je dois faire un sommaire par ordre alpha des thèmes. Et comme je ne sais pas faire ça, je contourne le problème en les copiant dans le bon ordre (l'ordre alpha).

Comment peut-on faire ce tri au préalable?

J'imagine qu'il faut remplir une table avec le nom de tous les .doc du répertoire, mais le tri...

Merci pour vos lumières et suggestions.

Bises

C@thy

 

[C@thy]

Re : copier les Fichiers d'un répertoire par ordre alpha

je vous joins mon fichier de tests mais la macro ne marche pas...

Biz

C@thy

 

[Efgé]

Re : copier les Fichiers d'un répertoire par ordre alpha

Bonjour C@thy,
Une proposition:
Pour récupérer les noms de fichiers:

[COLOR=blue]Sub[/COLOR] Liste_Classeur()
[COLOR=blue]Dim[/COLOR] Wb_Path$, Wb_Extension$, Wb_Name$, Msg$, i&, Tablo()
Application.ScreenUpdating = [COLOR=blue]False[/COLOR]
i = 0
[COLOR=blue]ReDim[/COLOR] Tablo(i)
Wb_Path = "C:Tempo\"[COLOR=green] ' Chemin a adapter[/COLOR]
Wb_Extension = ".xls"[COLOR=green] ' Extention à adapter[/COLOR]
Wb_Name = Dir(Wb_Path & "*" & Wb_Extension)
    [COLOR=blue]Do While[/COLOR] Wb_Name <> ""
            i = i + 1
            [COLOR=blue]ReDim Preserve[/COLOR] Tablo(i)
            Tablo(i) = UCase(Wb_Name)
        Wb_Name = Dir
    [COLOR=blue]Loop[/COLOR]
[COLOR=blue]Call[/COLOR] tri(Tablo, 0, [COLOR=blue]UBound[/COLOR](Tablo, 1))
MsgBox Join(Tablo, vbLf)[COLOR=green] ' Visualisation du tableau[/COLOR]
Application.ScreenUpdating = [COLOR=blue]True[/COLOR]
[COLOR=blue]End Sub[/COLOR]

Et ensuite le tri:

[COLOR=blue]Sub[/COLOR] tri(a, gauc, droi)[COLOR=green] ' Quick sort JB [URL="http://boisgontierjacques.free.fr/"]Formation Excel VBA JB[/URL][/COLOR]
   ref = a((gauc + droi) \ 2)
   g = gauc: d = droi
   [COLOR=blue]Do[/COLOR]
     [COLOR=blue]Do While[/COLOR] a(g) < ref: g = g + 1: [COLOR=blue]Loop[/COLOR]
     [COLOR=blue]Do While[/COLOR] ref < a(d): d = d - 1: [COLOR=blue]Loop[/COLOR]
     [COLOR=blue]If[/COLOR] g <= d [COLOR=blue]Then[/COLOR]
       temp = a(g): a(g) = a(d): a(d) = temp
       g = g + 1: d = d - 1
     [COLOR=blue]End If[/COLOR]
   [COLOR=blue]Loop While[/COLOR] g <= d
   [COLOR=blue]If[/COLOR] g < droi [COLOR=blue]Then Call[/COLOR] tri(a, g, droi)
   [COLOR=blue]If[/COLOR] gauc < d [COLOR=blue]Then Call[/COLOR] tri(a, gauc, d)
[COLOR=blue]End Sub[/COLOR]

Cordialement

 

[C@thy]

Re : copier les Fichiers d'un répertoire par ordre alpha

Coucou Efgé,

on s'est télescopés on dirait...

Un grand MERCI à toi.
Je teste ça tout de suite.

Bises

C@thy

 

[C@thy]

Re : copier les Fichiers d'un répertoire par ordre alpha

OK, chez moi j'ai modifié comme ceci :
Wb_Path = ThisWorkbook.Path ' Chemin a adapter
Wb_Extension = ".doc" ' Extention à adapter
Wb_Name = Dir(Wb_Path & "\*" & Wb_Extension)

Un super Merci à toi.

Bises

C@thy

 

[Efgé]

Re : copier les Fichiers d'un répertoire par ordre alpha

Re
En fait il rsique d'y avoir un problème.
La cellule Tablo(0) est vide .
Le bug est réparé:

[COLOR=blue]Sub[/COLOR] Liste_Classeur2()
[COLOR=blue]Dim[/COLOR] Wb_Path$, Wb_Extension$, Wb_Name$, i&, Tablo()
Application.ScreenUpdating = [COLOR=blue]False[/COLOR]
i = 0
Wb_Path = ThisWorkbook.Path & "\"
Wb_Extension = ".doc"
Wb_Name = Dir(Wb_Path & "*" & Wb_Extension)
[COLOR=blue]Do While[/COLOR] Wb_Name <> ""
    i = i + 1
    [COLOR=blue]ReDim Preserve[/COLOR] Tablo(1 [COLOR=blue]To[/COLOR] i)
    Tablo(i) = UCase(Wb_Name)
    Wb_Name = Dir
[COLOR=blue]Loop[/COLOR]
[COLOR=blue]If[/COLOR] i > 1 [COLOR=blue]Then Call[/COLOR] tri(Tablo, 1, [COLOR=blue]UBound[/COLOR](Tablo, 1))
MsgBox Join(Tablo, vbLf)[COLOR=green] ' Visualisation du tableau[/COLOR]
Application.ScreenUpdating = [COLOR=blue]True[/COLOR]
[COLOR=blue]End Sub[/COLOR]

Cordialement

 

[C@thy]

Re : copier les Fichiers d'un répertoire par ordre alpha

Ah oui, je comprends ce que tu veux dire.

Ca marchait mais la 1ère occurence du tableau était vide...

m'en étais même pas aperçue!!!

Euh tu as raison, mieux vaut mettre l'\ dans le chemin...

Biz

C@thy

 

[C@thy]

Re : copier les Fichiers d'un répertoire par ordre alpha

Bonsoir le forum

j'ai bien avancé sur le sujet,
il ne me reste plus qu'un léger détail :

je recherche dans chaque sous-répertoire (lundi, mardi... vendredi) tous les fichiers .doc et je les range dans une table,
ensuite, je trie la table selon l'ordre alpha des thèmes (affaires étrangères, immigration, social, culture, économie...) et la date de dernière modif puis j'ouvre les fichiers un à un pour les copier, dans l'ordre indiqué ci-dessus,

mais j'ai un problème avec mon tri car mes fichiers restent triés par thème à l'intérieur d'un répertoire et non pas juste triés par thème, quel que soit le répertoire.

voici mon code :

Public sem As Integer, semaine As Integer, jsem$
Public chemin As String, chemsem As String, Dossier As Object, Fichier As Object
Public ATraiter() As String, ATraiterchem() As String, DateModif() As Date, i As Integer
Public semainedu As String, elem As String
Public Mondoc As String, Nomdoc As String

Sub TraitDeb()
Dim Mondoc As String
Mondoc = ThisDocument.Name
Selection.Find.ClearFormatting
    With Selection.Find
        .Text = "SOMMAIRE"
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute
    Selection.Collapse
    Selection.MoveRight Unit:=wdWord, Count:=2, Extend:=wdMove
    On Error Resume Next
    ActiveDocument.TablesOfContents(1).Delete
    Selection.MoveRight Unit:=wdWord, Count:=2, Extend:=wdMove
    Selection.EndKey Unit:=wdStory, Extend:=wdExtend
    If Len(Selection) > 1 Then Selection.Delete
    Selection.Collapse
    Selection.TypeParagraph
    Selection.Style = ActiveDocument.Styles("Normal")
End Sub

Sub AcquisitionDossier()
Dim fd As FileDialog, vrtSelectedItem As Variant
Set fd = Application.FileDialog(msoFileDialogFolderPicker) 'selection répertoire
With fd
    chemin = ThisDocument.Path & "\"
End With
With fd
   .InitialFileName = chemin
   If .Show Then
        chemin = .SelectedItems(1)
   End If
End With
Set fd = Nothing
End Sub

Sub ListeDay() 'création de la liste des fichiers du jour à agréger
ChangeFileOpenDirectory chemin
i = 0
Set Dossier = CreateObject("Scripting.FileSystemObject").getfolder(chemin)
For Each Fichier In Dossier.Files
    If Right(Fichier.Name, 4) = ".doc" And LCase(Left(Fichier.Name, 9)) <> "prompteur" Then  ' liste les fichier DOC seulement
        ReDim Preserve ATraiter(i) ' pour les noms des fichiers valides
        ReDim Preserve DateModif(i) ' pour les dates
        ATraiter(i) = Fichier.Name
        DateModif(i) = Fichier.DateLastModified
        i = i + 1
    End If
Next
Call tri(ATraiter, 0, UBound(ATraiter, 1))
End Sub

Sub ListeWeek() 'création de la liste des fichiers de la semaine à agréger
ChangeFileOpenDirectory chemin
Set Dossier = CreateObject("Scripting.FileSystemObject").getfolder(chemin)
i = 0
For Each SousDossier In Dossier.SubFolders
chemin = SousDossier
  For Each Fichier In SousDossier.Files
    If Right(Fichier.Name, 4) = ".doc" And LCase(Left(Fichier.Name, 9)) <> "prompteur" Then  ' liste les fichier DOC seulement
        ReDim Preserve ATraiter(i) ' pour les noms des fichiers valides
        ReDim Preserve DateModif(i) ' pour les dates
        ReDim Preserve ATraiterchem(i) 'chemin complet
        ATraiter(i) = Fichier.Name
        DateModif(i) = Fichier.DateLastModified
        ATraiterchem(i) = chemin & "\" & Fichier.Name
        i = i + 1
    End If
  Next
Next
Call tri(ATraiter, 0, UBound(ATraiter, 1))
End Sub

Sub tri(a, gauc, droi)
   ref = a((gauc + droi) \ 2)
   g = gauc: d = droi
   Do
     Do While a(g) < ref: g = g + 1: Loop
     Do While ref < a(d): d = d - 1: Loop
     If g <= d Then
       Temp = a(g): a(g) = a(d): a(d) = Temp
       g = g + 1: d = d - 1
     End If
   Loop While g <= d
   If g < droi Then Call tri(a, g, droi)
   If gauc < d Then Call tri(a, gauc, d)
End Sub

Sub TraitWeek()
'si j'ai choisi le répertoire semaine (ex. 47) j'agrège tous les fichiers des répertoires semaine
Dim v
Dim Nomdoc As String
Selection.EndKey Unit:=wdStory
Mondoc = ActiveDocument.Name
For i = LBound(ATraiter) To UBound(ATraiter)
    On Error GoTo 0
    ChangeFileOpenDirectory chemin
    Documents.Open filename:=ATraiterchem(i), _
    ConfirmConversions:=False, ReadOnly:=False, AddToRecentFiles:=False, _
    PasswordDocument:="", PasswordTemplate:="", Revert:=False, _
    WritePasswordDocument:="", WritePasswordTemplate:="", Format:= _
    wdOpenFormatAuto, XMLTransform:=""
    v = Split(ActiveDocument.Path, "\")
    sem = IIf(UBound(v) > 0, v(UBound(v) - 1), v(UBound(v)))
    Nomdoc = ActiveDocument.Name
    Documents(Mondoc).Activate
    With Selection
       .InsertBreak Type:=wdPageBreak
       .TypeText Text:=Nomdoc & " : " & DateModif(i)
       .Style = ActiveDocument.Styles("Cathy")
       .TypeParagraph
       .Style = ActiveDocument.Styles("Normal")
       End With
     Documents(Nomdoc).Activate
     With Selection
        .WholeStory 'tout sélectionner
        .Copy
        ActiveWindow.Close
        Selection.EndKey Unit:=wdStory 'fin du doc
        Selection.PasteAndFormat (wdPasteDefault)
End With
Next i
End Sub

Sub TraitDay() 'si j'ai choisi un répertoire jour (ex. lundi) j'agrège tous les fichiers du jour
Dim Mondoc As String
Mondoc = ThisDocument.Name
Dim v
v = Split(ActiveDocument.Path, "\")
sem = IIf(UBound(v) > 0, v(UBound(v) - 1), v(UBound(v)))
Selection.EndKey Unit:=wdStory
For i = LBound(ATraiter) To UBound(ATraiter)
  On Error GoTo 0
  With Selection
    .InsertBreak Type:=wdPageBreak
    .TypeText Text:=ATraiter(i) & " : " & DateModif(i)
    .Style = ActiveDocument.Styles("Cathy")
    .TypeParagraph
    .Style = ActiveDocument.Styles("Normal")
  ChangeFileOpenDirectory chemin
  Documents.Open filename:=ATraiter(i), _
    ConfirmConversions:=False, ReadOnly:=False, AddToRecentFiles:=False, _
    PasswordDocument:="", PasswordTemplate:="", Revert:=False, _
    WritePasswordDocument:="", WritePasswordTemplate:="", Format:= _
    wdOpenFormatAuto, XMLTransform:=""
  Selection.WholeStory 'tout sélectionner
  Selection.Copy
  ActiveWindow.Close
  Selection.EndKey Unit:=wdStory 'fin du doc
  Selection.PasteAndFormat (wdPasteDefault)
End With
Next i
End Sub

Mon problème :
si je trie par ordre alpha du nom des fichiers, ils seront triés par thème, puisque celui_ci figure en début de nom de fichier, mais du coup exit le tri par date...
Ce problème vous semble-t-il insoluble???

En tout cas mon tri ne marche pas car j'ai des affaires étrangères, puis du social, puis des affaires étrangères (d'un autre jour)... Damned!

Un aide (ou un début d'aide) de votre part serait vraiment bienvenue car je ne m'en sors pas, alors qu'il ne me reste que ce point pour que tout fonctionne à merveille...
Un grand merci à vous si vous pouvez me mettre sur le chemin d'une solution.

Bises

C@thy