Ouvrir classeurs excel en fonction de leurs dates de création

Version imprimable

27/02/2012, 12h49
ronaindor

Ouvrir classeurs excel en fonction de leurs dates de création

Bonjour,

J'aurai besoin de votre aide pour un problème que je n'arrive pas à résoudre vu mon niveau de débutant en VBa Excel.

Je voudrais ouvrir les classeurs excels contenus dans un dossier en fonction de leur date de création, soit du plus récent au plus ancien.

J'éspére que vous pourrez m'aider car je suis vraiment coincé...

Merci de votre aide.
27/02/2012, 13h24
kiki29

Salut, à lire dans la FAQ http://excel.developpez.com/sources/...ersDecroissant
27/02/2012, 14h57
ronaindor

Merci pour ta réponse kiki29,

Mais le seul problème c'est que je veux ouvrir des fichiers de ce dossier mais aussi de ses sous dossiers...

C'est là que je bloque...

Merci

Je suppose donc qu'il va aussi falloir ouvrir les dossiers en fonction de leur date de création....

Cordialement
27/02/2012, 15h14
kiki29

Re, pour la recherche récursive voir http://www.developpez.net/forums/d20...feuille-excel/ et combiner avec la solution donnée plus haut
27/02/2012, 15h56
ronaindor

Cela parait peut être facile pour toi mais je n'arrive pas à combiner les deux...

Si tu pouvais m'aider ça serait simpa !

Merci
27/02/2012, 17h19
kiki29

Re, en fait même pas besoin de combiner, la 2 eme proposition marche telle quelle, mais tu peux élaguer les infos inutiles et faire un tri sur la colonne contenant la date de création
Pour ce tri tu peux y parvenir avec l'enregistreur de macros
27/02/2012, 17h54
ronaindor

Je suis désolé mais cela fait deux heures que j'essaye et je n'y arrive vraiment pas...

Pourriez vous essayer de les assembler pour arriver à ce que je veux ?

Merci,

Cordialement

Re, plus de références à cocher, affecter un bouton à Tst
ShFichiers est le CodeName de la feuille recevant les données
voir http://www.developpez.net/forums/d92...cel/vba-bases/

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
Option Explicit
 
Dim iRow As Long
Dim bNotFirstTime As Boolean
 
Private Sub ListFilesInFolder(strFolderName As String, bIncludeSubfolders As Boolean)
Dim FSO As Object
Dim oSourceFolder As Object
Dim oSubFolder As Object
Dim oFile As Object
 
    Set FSO = CreateObject("Scripting.FileSystemObject")
    If Not bNotFirstTime Then
        ShFichiers.Cells(1, 1) = "Chemin"
        ShFichiers.Cells(1, 2) = "Date Création"
        iRow = 2
        bNotFirstTime = True
    End If
 
    Set oSourceFolder = FSO.GetFolder(strFolderName)
    For Each oFile In oSourceFolder.Files
        ShFichiers.Cells(iRow, 1) = oFile.Path
        ShFichiers.Cells(iRow, 2) = oFile.DateCreated
        iRow = iRow + 1
    Next oFile
 
    If bIncludeSubfolders Then
        For Each oSubFolder In oSourceFolder.SubFolders
            ListFilesInFolder oSubFolder.Path, True
        Next oSubFolder
    End If
 
    Application.StatusBar = iRow - 1
    Set oSourceFolder = Nothing
    Set FSO = Nothing
End Sub
 
Private Sub Tri()
    ShFichiers.Range("A2:B" & Rows.Count).Sort Key1:=ShFichiers.Range("B2"), Order1:=xlDescending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
    ShFichiers.Range("C1").Select
End Sub
 
Sub Tst()
Dim sChemin As String
 
    sChemin = ThisWorkbook.Path
    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = sChemin & "\"
        .Title = "Dossier à traiter"
        .AllowMultiSelect = False
        .InitialView = msoFileDialogViewDetails
        .ButtonName = "Sélection Dossier"
        .Show
        If .SelectedItems.Count > 0 Then
            DoEvents
            Application.ScreenUpdating = False
            ShFichiers.Cells.Clear
            bNotFirstTime = False
            ListFilesInFolder .SelectedItems(1), True
            Tri
            Application.ScreenUpdating = True
        End If
    End With
End Sub

On peut également tranformer le chemin en lien hypertexte

28/02/2012, 09h01
ronaindor

Désolé mais ce n'est pas ce que je veux.

Ton code me demande à chaque fois le dossier à traiter alors que je veux en définir un dans le code. Et il m'inscrit un nom de dossier avec son chemin et sa date de création dans une feuille alors que je veux pas que cela soit insérer dans une feuille.

Je veux juste que la macro m'ouvre chaque fichier contenu dans un dossier et ses sous dossiers suivant leur date de création (plus récent au plus ancien) pour en extraire une plage de valeurs.

Merci
28/02/2012, 11h16
kiki29

Salut, Tu veux ? ...
question subsidaire : quel est le type de tes fichiers ?
28/02/2012, 11h34
ronaindor

Ce sont des fichiers Excel dans lesquels je veux copier un range de données pour le coller dans une feuille de mon classeur.

Voila, j'éspère être assez clair ...

Merci de votre aide

Cordialement

Re, à voir

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
Option Explicit
 
Dim iRow As Long
Dim bNotFirstTime As Boolean
Const TypeFichier As String = "xls"
 
Private Sub ListFilesInFolder(strFolderName As String, bIncludeSubfolders As Boolean)
Dim FSO As Object
Dim oSourceFolder As Object
Dim oSubFolder As Object
Dim oFile As Object
 
    Set FSO = CreateObject("Scripting.FileSystemObject")
    If Not bNotFirstTime Then
        ShFichiers.Cells(1, 1) = "Chemin"
        ShFichiers.Cells(1, 2) = "Date Création"
        iRow = 2
        bNotFirstTime = True
    End If
 
    Set oSourceFolder = FSO.GetFolder(strFolderName)
    For Each oFile In oSourceFolder.Files
        If UCase(TypeFichier) = UCase(FSO.GetExtensionName(oFile)) Then
            ShFichiers.Cells(iRow, 1) = oFile.Path
            ShFichiers.Cells(iRow, 2) = oFile.DateCreated
            iRow = iRow + 1
        End If
    Next oFile
 
    If bIncludeSubfolders Then
        For Each oSubFolder In oSourceFolder.SubFolders
            ListFilesInFolder oSubFolder.Path, True
        Next oSubFolder
    End If
 
    Application.StatusBar = iRow - 1
    Set oSourceFolder = Nothing
    Set FSO = Nothing
End Sub
 
Private Sub Ouvrir()
Dim i As Long, LastRow As Long
    LastRow = ShFichiers.Range("A" & Rows.Count).End(xlUp).Row
    For i = 2 To LastRow
        Workbooks.Open Filename:=ShFichiers.Range("A" & i)
    Next i
End Sub
 
Private Sub Tri()
    ShFichiers.Range("A2:B" & Rows.Count).Sort Key1:=ShFichiers.Range("B2"), Order1:=xlDescending, Header:=xlGuess, _
                                               OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
                                               DataOption1:=xlSortNormal
    ShFichiers.Range("C1").Select
End Sub
 
Sub Tst()
Dim sChemin As String
    sChemin = "C:\Transfert\Test\"
    Application.ScreenUpdating = False
    ShFichiers.Cells.Clear
    bNotFirstTime = False
    ListFilesInFolder sChemin, True
    Tri
    Ouvrir
    Application.ScreenUpdating = True
End Sub

28/02/2012, 14h25
ronaindor

Désolé mais cela ne fonctionne pas.

La macro n'ouvre pas les fichiers dans l'ordre et importe toujours le chemin et la date de création de chaque fichier.

Cela n'a pas l'air simple...
28/02/2012, 14h44
kiki29

re, aucune importance pour l'import du nom des fichiers, joue sur l'ordre de tri
si c'est simple simplement plus de temps à perdre
28/02/2012, 15h39
ronaindor

Tanpis je resterai coincé ....

Salut, j'ai retrouvé un peu de temps, il y aura sans doute des ajustements à faire sur la plage à copier ou le type de fichier xls,xlsm,xlsb ... ?, à toi de voir.Ici tout fonctionne correctement

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
Option Explicit
 
Dim iRow As Long
Dim Ar() As String
Const TypeFichier As String = "xls"
 
Private Sub ListFilesInFolder(strFolderName As String, bIncludeSubfolders As Boolean)
Dim FSO As Object
Dim oSourceFolder As Object
Dim oSubFolder As Object
Dim oFile As Object
 
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set oSourceFolder = FSO.GetFolder(strFolderName)
 
    For Each oFile In oSourceFolder.Files
        If UCase(TypeFichier) = UCase(FSO.GetExtensionName(oFile)) Then
            iRow = iRow + 1
            ShFichiers.Cells(iRow, 1) = oFile.Path
            ShFichiers.Cells(iRow, 2) = oFile.DateCreated
        End If
    Next oFile
 
    If bIncludeSubfolders Then
        For Each oSubFolder In oSourceFolder.SubFolders
            ListFilesInFolder oSubFolder.Path, True
        Next oSubFolder
    End If
 
    Application.StatusBar = iRow 
    Set oSourceFolder = Nothing
    Set FSO = Nothing
End Sub
 
Private Sub OuvrirEtCopier()
Dim i As Long, Wkb As Workbook
Dim T() As Variant
 
    For i = 1 To UBound(Ar) - 1
        Set Wkb = Workbooks.Open(Filename:=Ar(i))
        T = ActiveSheet.Range("A1:D" & ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row).Value
        ShFichiers.Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(UBound(T, 1), UBound(T, 2)) = T
        Wkb.Close
    Next i
    Set Wkb = Nothing
    Erase T
    ShFichiers.Rows("1:1").Delete Shift:=xlUp
    ShFichiers.Range("E1").Select
End Sub
 
Private Sub Tableau()
Dim i As Long, LastRow As Long
    LastRow = ShFichiers.Range("A" & Rows.Count).End(xlUp).Row
    For i = 1 To LastRow
        ReDim Preserve Ar(i + 1)
        Ar(i) = ShFichiers.Range("A" & i)
    Next i
    ShFichiers.Cells.Clear
End Sub
 
Private Sub Tri()
    ShFichiers.Range("A1:B" & Rows.Count).Sort Key1:=ShFichiers.Range("B1"), Order1:=xlDescending, Header:=xlGuess, _
                                               OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
                                               DataOption1:=xlSortNormal
End Sub
 
Sub Tst()
Dim sChemin As String
    sChemin = "C:\Transfert\Test\"
    Application.ScreenUpdating = False
    ShFichiers.Cells.Clear
    iRow = 0
    ListFilesInFolder sChemin, True
    Tri
    Tableau
    OuvrirEtCopier
    Application.ScreenUpdating = True
End Sub

Ajout d'un menu contextuel ( clic droit ) puis Import/Lancer
Dans module ThisWorkBook ajouter

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
 
Option Explicit
 
Dim MenuPrincipal As CommandBarPopup
Dim SousMenu1 As CommandBarControl 
 
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
    EffacerMenus
End Sub
 
Private Sub Workbook_Deactivate()
    EffacerMenus
End Sub
 
Private Sub Workbook_SheetBeforeRightClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)
    EffacerMenus
    Set MenuPrincipal = Application.CommandBars("cell").Controls.Add(Type:=msoControlPopup, before:=1, temporary:=True)
    With MenuPrincipal
        .Caption = "Import"
        .BeginGroup = True
    End With
 
    Set SousMenu1 = MenuPrincipal.Controls.Add(Type:=msoControlButton)
    With SousMenu1
       .Caption = "Lancer"
       .OnAction = "Tst"
       .FaceId = 2105
    End With
End Sub
 
Private Sub EffacerMenus()
Dim Ctrl As CommandBarControl
    For Each Ctrl In Application.CommandBars("Cell").Controls
        If Ctrl.Caption = "Import" Then Ctrl.Delete
    Next Ctrl
End Sub

02/03/2012, 08h54
ronaindor

Effectivement tout fonctionne correctement! Merci!

Je voudrai maintenant émettre une condition sur le nom des fichiers à ouvrir (ex: ouvrir si "standardreport" contenu dans le nom du fichier) et ouvrir uniquement les fichiers qui n'ont pas encore été importés.

Voila, si tu as une idée, merci de ton aide !
02/03/2012, 10h01
kiki29
Salut, pour standardreport : dans procédure ListFilesInFolder(strFolderName As String, bIncludeSubfolders As Boolean)
Code:

1 2 3 4 ... If UCase(TypeFichier) = UCase(FSO.GetExtensionName(oFile)) And InStr(oFile, "standardreport") > 0 Then ...
05/03/2012, 15h45
ronaindor

Bonjour !

Il y a un problème avec la macro. Elle trie les fichiers par ordre de dernière modification et non par ordre de création.

Peut être avez vous une idée ?

Merci, bonne journée