[VBA Excel] Rechercher, Copier, Imprimer

**ancel17** · 17/06/2008, 19h51

Bonjour à tous,

Voici une petite contribution de ma part pour ceux qui en auront besoin...

Le but du fichier Excel et du code associé est de permettre la recherche de fichiers avec des noms proches (pour moi j'ai une vingtaine de fichiers qui s'appellent "DSCP qqch Date") dispatchés dans plusieurs dossiers (3 dossiers sources contenant de nombreux sous-dossiers dans mon cas).

Je devais archiver dans 3 dossiers cibles (1 dossier cible par dossier source) les fichiers "DSCP qqch Date" et les regrouper par Date dans un sous-dossier "DSCP Date".
Vous commencez à imaginer la perte de temps... D'autant plus que chaque fichier devait être imprimé dans sa totalité (4 feuilles par fichier) !

J'ai donc réduit mon temps de travail de 2 h à 5 min. (et de 15 aller-retour vers l'imprimante à 1 seul)

Vous pouvez télécharger le fichier magique joint !

Fonctionnement du fichier :
- Renseigner les cellules A2 et A3 sur les éléments que doit contenir le nom du fichier (la recherche s'effectuera sur un nom de fichier du type "*A2*A3*"
- Renseigner dans la colonne B les adresses des dossiers sources
- Renseigner dans la colonne C les adresses des dossiers cibles (il faut une adresse cible par adresse source, les adresses cibles peuvent être les mêmes par exemple si vous archivez tous les fichiers dans un seul et même dossier)
- Renseigner ce que vous voulez faire des fichiers qui correspondront à votre recherche (Copier dans le dossier cible et/ou Imprimer)
- Cliquer sur le bouton Ok, et c'est parti !

Une boite de dialogue vous liste les éléments trouvés par dossier sources et demande une confirmation de copie et/ou d'impression.

Enjoy !

Pour ceux que le fichier n'intéresse pas mais qui souhaitent consulter son code pour une raison quelconque, le voici :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
79
80
81
82
83
84
Private Sub CommandButton1_Click()
 
Dim FSO As New FileSystemObject
Dim Fo As Folder
Dim Fi As File
Dim c As Range
Dim Fl As Worksheet, Fl2 As Worksheet
Dim Wb As Workbook
Dim strSearch(1) As String, NomFich As String
 
Set Fl = ThisWorkbook.Worksheets(1)
 
strSearch(0) = Fl.Range("A2").Value: strSearch(1) = Fl.Range("A3")
 
For Each c In Fl.Range("B2:B" & Fl.Range("B1").SpecialCells(xlCellTypeLastCell).Row).Cells
    If Fl.Range("D" & c.Row) = "oui" Or Fl.Range("E" & c.Row) = "oui" Then
        d = 0
        UserForm1.Label1.Caption = ""
        UserForm1.Label2.Caption = ""
        UserForm1.Label3.Caption = "Les fichiers suivants vont être copiés vers :" & Chr(10) & Fl.Range("C" & c.Row).Characters(55, Fl.Range("C" & c.Row).Characters.Count).Caption
        UserForm1.Label5.Caption = 0
        With Application.FileSearch
            .NewSearch
            .LookIn = c.Value
            .SearchSubFolders = True
            .Filename = "*" & strSearch(0) & "*" & strSearch(1) & "*"
            If .Execute > 0 Then
Copie_Impression:
                If UserForm1.Label5.Caption = 1 Then
                    Application.ScreenUpdating = False
                    UserForm1.Label5.Caption = 2
                    For Each Fo In FSO.GetFolder(Fl.Range("C" & c.Row).Value).SubFolders
                        If Fo.Path = Fl.Range("C" & c.Row).Value & "\" & strSearch(0) & " " & Left(strSearch(1), 8) Then
                            d = 1
                        End If
                    Next Fo
                    If Not d = 1 Then
                        MkDir Fl.Range("C" & c.Row).Value & "\" & strSearch(0) & " " & Left(strSearch(1), 8)
                    End If
                End If
                For i = 1 To .FoundFiles.Count
                    If Fl.Range("D" & c.Row) = "oui" Then
                        If UserForm1.Label5.Caption = 0 Then
                            NomFich = StrReverse(Left(StrReverse(.FoundFiles(i)), InStr(StrReverse(.FoundFiles(i)), "\") - 1))
                            If i = 1 Then
                                UserForm1.Label1.Caption = NomFich
                            Else
                                UserForm1.Label1.Caption = UserForm1.Label1.Caption & Chr(10) & NomFich
                            End If
                        Else
                            Set Fi = FSO.GetFile(.FoundFiles(i))
                            Fi.Copy Fl.Range("C" & c.Row).Value & "\" & strSearch(0) & " " & Left(strSearch(1), 8) & "\" & Fi.Name
                        End If
                    End If
                    If Fl.Range("E" & c.Row) = "oui" Then
                        If UserForm1.Label5.Caption = 0 Then
                            If i = 1 Then
                                UserForm1.Label2.Caption = NomFich
                            Else
                                UserForm1.Label2.Caption = UserForm1.Label1.Caption & Chr(10) & NomFich
                            End If
                        Else
                            Set Fi = FSO.GetFile(.FoundFiles(i))
                            Set Wb = Workbooks.Open(Fi.Path)
                            For Each Fl2 In Wb.Worksheets
                                Fl2.PrintOut
                            Next Fl2
                            Wb.Close
                        End If
                    End If
                Next i
                If UserForm1.Label5.Caption = 0 Then UserForm1.Show
'--------------------------------------------------------------------------
'En cliquant sur Ok du UserForm1, on passe UserForm1.Label5.Caption à 1 et on ferme le UserForm1
'En cliquant sur Annuler, on ferme le UserForm1 sans changer UserForm1.Label5.Caption
'--------------------------------------------------------------------------
                If UserForm1.Label5.Caption = 1 Then GoTo Copie_Impression
                If UserForm1.Label5.Caption = 2 Then Application.ScreenUpdating = True
            End If
        End With
    End If
Next c
 
End Sub

Ce code fonctionne, mais il est très certainement optimisable, donc n'hésitez pas !

**Le Pierre** · 17/06/2008, 20h17

bonjour

il y a un problème avec ton fichier. Peux-tu nous le remettre sur le forum.
Merci

**ancel17** · 18/06/2008, 14h23

Salut tout le monde !

Pour ce qui est du fichier, je suis en train de voir mes possibilités avec un administrateur.

**ancel17** · 01/08/2008, 11h21

Bonjour,

Pas de solution trouvée pour le moment en ce qui concerne le problème du fichier donc je vais vous guider pour la conception fort simple de l'outil...

Téléchargez le fichier joint, il servira de base !

Insérez le code suivant dans la zone de code allouée à la feuille 1 :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
79
80
81
82
83
84
Private Sub CommandButton1_Click()
 
Dim FSO As New FileSystemObject
Dim Fo As Folder
Dim Fi As File
Dim c As Range
Dim Fl As Worksheet, Fl2 As Worksheet
Dim Wb As Workbook
Dim strSearch(1) As String, NomFich As String
 
Set Fl = ThisWorkbook.Worksheets(1)
 
strSearch(0) = Fl.Range("A2").Value: strSearch(1) = Fl.Range("A3")
 
For Each c In Fl.Range("B2:B" & Fl.Range("B1").SpecialCells(xlCellTypeLastCell).Row).Cells
    If Fl.Range("D" & c.Row) = "oui" Or Fl.Range("E" & c.Row) = "oui" Then
        d = 0
        UserForm1.Label1.Caption = ""
        UserForm1.Label2.Caption = ""
        UserForm1.Label3.Caption = "Les fichiers suivants vont être copiés vers :" & Chr(10) & Fl.Range("C" & c.Row).Characters(55, Fl.Range("C" & c.Row).Characters.Count).Caption
        UserForm1.Label5.Caption = 0
        With Application.FileSearch
            .NewSearch
            .LookIn = c.Value
            .SearchSubFolders = True
            .Filename = "*" & strSearch(0) & "*" & strSearch(1) & "*"
            If .Execute > 0 Then
Copie_Impression:
                If UserForm1.Label5.Caption = 1 Then
                    Application.ScreenUpdating = False
                    UserForm1.Label5.Caption = 2
                    For Each Fo In FSO.GetFolder(Fl.Range("C" & c.Row).Value).SubFolders
                        If Fo.Path = Fl.Range("C" & c.Row).Value & "\" & strSearch(0) & " " & Left(strSearch(1), 8) Then
                            d = 1
                        End If
                    Next Fo
                    If Not d = 1 Then
                        MkDir Fl.Range("C" & c.Row).Value & "\" & strSearch(0) & " " & Left(strSearch(1), 8)
                    End If
                End If
                For i = 1 To .FoundFiles.Count
                    If Fl.Range("D" & c.Row) = "oui" Then
                        If UserForm1.Label5.Caption = 0 Then
                            NomFich = StrReverse(Left(StrReverse(.FoundFiles(i)), InStr(StrReverse(.FoundFiles(i)), "\") - 1))
                            If i = 1 Then
                                UserForm1.Label1.Caption = NomFich
                            Else
                                UserForm1.Label1.Caption = UserForm1.Label1.Caption & Chr(10) & NomFich
                            End If
                        Else
                            Set Fi = FSO.GetFile(.FoundFiles(i))
                            Fi.Copy Fl.Range("C" & c.Row).Value & "\" & strSearch(0) & " " & Left(strSearch(1), 8) & "\" & Fi.Name
                        End If
                    End If
                    If Fl.Range("E" & c.Row) = "oui" Then
                        If UserForm1.Label5.Caption = 0 Then
                            If i = 1 Then
                                UserForm1.Label2.Caption = NomFich
                            Else
                                UserForm1.Label2.Caption = UserForm1.Label1.Caption & Chr(10) & NomFich
                            End If
                        Else
                            Set Fi = FSO.GetFile(.FoundFiles(i))
                            Set Wb = Workbooks.Open(Fi.Path)
                            For Each Fl2 In Wb.Worksheets
                                Fl2.PrintOut
                            Next Fl2
                            Wb.Close
                        End If
                    End If
                Next i
                If UserForm1.Label5.Caption = 0 Then UserForm1.Show
'--------------------------------------------------------------------------
'En cliquant sur Ok du UserForm1, on passe UserForm1.Label5.Caption à 1 et on ferme le UserForm1
'En cliquant sur Annuler, on ferme le UserForm1 sans changer UserForm1.Label5.Caption
'--------------------------------------------------------------------------
                If UserForm1.Label5.Caption = 1 Then GoTo Copie_Impression
                If UserForm1.Label5.Caption = 2 Then Application.ScreenUpdating = True
            End If
        End With
    End If
Next c
 
End Sub

Créez un nouveau UserForm qui s'appellera UserForm1 composé de :
- 5 étiquettes (Label1, Label2,... Label5)
- 2 boutons (Ok et Annuler)

Vous pouvez vous inspirer de l'image jointe...

Insérez ce code pour le bouton Ok du UserForm1 :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
Private Sub CommandButton1_Click()
UserForm1.Label5 = 1
UserForm1.Hide
End Sub

Et ce code pour le bouton Annuler :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
Private Sub CommandButton2_Click()
UserForm1.Hide
End Sub

Si vous le souhaitez, vous pouvez également ajouter ce code à la feuille 1 :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target = Range("A2") Or Target = Range("A3") Then
    Range("C1").Comment.Text "Un dossier " & Range("A2").Value & " " & Left(Range("A3"), 8) & " sera automatiquement créé." & Chr(10) & "Les fichiers copiés y seront alors collés."
End If
End Sub

Ce code met à jour le commentaire inséré en cellule C1...

Voilà, cette fois je pense que vous avez tout !

[VBA Excel] Rechercher, Copier, Imprimer

Contribuez

Discussions similaires

Partager

Partager