gestion de Classeurs parFile Dialog avec savegarde sur autre dossier

**Igloobel** · 03/01/2018, 10h40

Bonjour et bonne année à tous

Je viens demander un peu d'aide sur quelque chose que je ne comprends pas

Il y a quelques temps j'ai demandé des explications comment recenser des images, graphique, Commentaires ...

et les bonnes âmes du site m'ont parlé des objets Shapes (je les remercie pleinement

)

et j'ai créer cette macro qui recense ces objets (elle fonctionne très bien

)

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
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
Sub Recense_Shapes()
    Dim Shp As Shape
    Dim Wsh As Worksheet
    Dim Tab_Shapes(1 To 2, 1 To 25) As Variant
    Dim Mess As String
    Dim i As Byte
 
    For i = 1 To 25
        Tab_Shapes(1, i) = 0
        Tab_Shapes(2, i) = ""
    Next
    Mess = "Pour le classeur " & ActiveWorkbook.Name & vbCrLf & vbCrLf & _
        "Les Objets Shapes recensés sont : " & vbCrLf & vbCrLf
 
 
    For Each Wsh In ActiveWorkbook.Worksheets
        Wsh.Activate
        For Each Shp In ActiveSheet.Shapes
            Select Case Shp.Type
                Case -2
                    Tab_Shapes(1, 1) = Tab_Shapes(1, 1) + 1
                    Tab_Shapes(2, 1) = "Type de forme mixte"
                Case 1
                    Tab_Shapes(1, 2) = Tab_Shapes(1, 2) + 1
                    Tab_Shapes(2, 2) = "Forme automatique"
                Case 2
                    Tab_Shapes(1, 3) = Tab_Shapes(1, 3) + 1
                    Tab_Shapes(2, 3) = "Légende"
                Case 3
                    Tab_Shapes(1, 4) = Tab_Shapes(1, 4) + 1
                    Tab_Shapes(2, 4) = "Graphique"
                Case 4
                    Tab_Shapes(1, 5) = Tab_Shapes(1, 5) + 1
                    Tab_Shapes(2, 5) = "Commentaire"
                Case 5
                    Tab_Shapes(1, 6) = Tab_Shapes(1, 6) + 1
                    Tab_Shapes(2, 6) = "Forme libre"
                Case 6
                    Tab_Shapes(1, 7) = Tab_Shapes(1, 7) + 1
                    Tab_Shapes(2, 7) = "Groupe"
                Case 7
                    Tab_Shapes(1, 8) = Tab_Shapes(1, 8) + 1
                    Tab_Shapes(2, 8) = "Objet OLE incorporé"
                Case 8
                    Tab_Shapes(1, 9) = Tab_Shapes(1, 9) + 1
                    Tab_Shapes(2, 9) = "Contrôle de formulaire"
                Case 9
                    Tab_Shapes(1, 10) = Tab_Shapes(1, 10) + 1
                    Tab_Shapes(2, 10) = "Trait"
                Case 10
                    Tab_Shapes(1, 11) = Tab_Shapes(1, 11) + 1
                    Tab_Shapes(2, 11) = "Objet OLE lié"
                Case 11
                    Tab_Shapes(1, 12) = Tab_Shapes(1, 12) + 1
                    Tab_Shapes(2, 12) = "Image liée"
                Case 12
                    Tab_Shapes(1, 13) = Tab_Shapes(1, 13) + 1
                    Tab_Shapes(2, 13) = "Objet de contrôle OLE"
                Case 13
                    Tab_Shapes(1, 14) = Tab_Shapes(1, 14) + 1
                    Tab_Shapes(2, 14) = "Image"
                Case 14
                    Tab_Shapes(1, 15) = Tab_Shapes(1, 15) + 1
                    Tab_Shapes(2, 15) = "Espace résevé"
                Case 15
                    Tab_Shapes(1, 16) = Tab_Shapes(1, 16) + 1
                    Tab_Shapes(2, 16) = "Effet de texte"
                Case 16
                    Tab_Shapes(1, 17) = Tab_Shapes(1, 17) + 1
                    Tab_Shapes(2, 17) = "Support"
                Case 17
                    Tab_Shapes(1, 18) = Tab_Shapes(1, 18) + 1
                    Tab_Shapes(2, 18) = "Zone de texte"
                Case 18
                    Tab_Shapes(1, 19) = Tab_Shapes(1, 19) + 1
                    Tab_Shapes(2, 19) = "Ancre de script"
                Case 19
                    Tab_Shapes(1, 20) = Tab_Shapes(1, 20) + 1
                    Tab_Shapes(2, 20) = "Tableau"
                Case 20
                    Tab_Shapes(1, 21) = Tab_Shapes(1, 21) + 1
                    Tab_Shapes(2, 21) = "Zone de dessin"
                Case 21
                    Tab_Shapes(1, 22) = Tab_Shapes(1, 22) + 1
                    Tab_Shapes(2, 22) = "Diagramme"
                Case 22
                    Tab_Shapes(1, 23) = Tab_Shapes(1, 23) + 1
                    Tab_Shapes(2, 23) = "Encre"
                Case 23
                    Tab_Shapes(1, 24) = Tab_Shapes(1, 24) + 1
                    Tab_Shapes(2, 24) = "Commentaire manuscrit"
                Case 24
                    Tab_Shapes(1, 25) = Tab_Shapes(1, 25) + 1
                    Tab_Shapes(2, 25) = "Graphique SmartArt"
            End Select
        Next Shp
    Next Wsh
 
    For i = 1 To 25
        If Tab_Shapes(1, i) <> 0 Then
        Mess = Mess & Tab_Shapes(1, i) & " de type " & Tab_Shapes(2, i) & vbCrLf
        End If
    Next
 
    MsgBox Mess, vbInformation, " Listes des shapes"
 
End Sub

A la suite de cela, j'ai donc créer une nouvelle macro car mon but est de supprimer ces objets

dans les classeurs de travail qui m'arrivent.

Dans cette nouvelle macro j'utilise deux types d'objets fileDialog
- un selectionneur dossier dialog box
- un selectionneur dossier dialog box

(Oui je sais que j'aurrais pu faire autrement mais je me suis fait plaiz ...

)

et cela marche bien ... enfin presque

La macro ouvre un File Open dialog box
je sélectionne un ou des classeur(s) grace à l'instruction : ".AllowMultiSelect = True"
La macro ouvre un selectionneur de dossier dialog box
Je sélectionne le dossier

(jusque là tout va bien)

Puis pour chaque classeur et pour chaque feuille on supprime les objet shapes.

mon problème c'est que cela marche bien pour un classeur
mais pas pour des classeurs il me met le contenu du premier classeur dans les autres

Exemple: si j'ai trois classeurs
- Class_A
- Class_B
- Class_C
le contenu de Class_A sera dans Class_A, Class_B, Class_C et les 3 classeurs seront bien présent

Voici ma macro

Si quelqu'un voit où est le problème merci d'avance de me l'indiquer parce que perso je voit pas

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
Sub Supp_Obj_Shapes()
    Dim Wrbk As Workbook
    Dim Chem_Select As String
    Dim Shp As Shape
    Dim Wsh As Worksheet
 
'ouverture d'un fichier par boite FileDialog
'**********************************************************
    'Declaration d'une variable comme objet FileDialog
    Dim fd As FileDialog
 
    'Creation d'un objet FileDialog comme un File Open dialog box.
    Set fd = Application.FileDialog(msoFileDialogOpen)
 
    'Déclaration d'une variable contenant le "path" de style variant
    Dim vrtSelectedItem As Variant 'obligatoirement de type variant
 
    With fd
        .AllowMultiSelect = True
        .InitialFileName = "C:\TEMPO\SELECT"
 
        If .Show = -1 Then
             .Execute
        Else
            Exit Sub
        End If
    End With
 
'----------------------------------------------
'Sélection d'un dossier par boite FileDialog
'**********************************************************
    'Declaration d'une variable comme objet FileDialog
    'Dim fd As FileDialog (déja déclarée)
 
    'Creation d'un objet FileDialog comme un selectionneur dossier dialog box.
    Set fd = Application.FileDialog(msoFileDialogFolderPicker)
 
    'Déclaration d'une variable contenant le "path" de style variant
    'Dim vrtSelectedItem As Variant 'obligatoirement de type variant (déja déclarée)
 
    With fd
        .InitialFileName = "C:\TEMPO\SAVE"
 
        If .Show = -1 Then
            'Step through each string in the FileDialogSelectedItems collection.
            For Each vrtSelectedItem In .SelectedItems
 
                'vrtSelectedItem est un String contenant le "path"  de chaque item selectionné.
                'affichage du "PATH et du fichier selectionné" dans une boite message
                'MsgBox "Vous avez sélectionné : " & vrtSelectedItem
                Chem_Select = vrtSelectedItem & "\"
            Next vrtSelectedItem
        Else
            Exit Sub
        End If
    End With
 
    'je suppose que mon problème est ici
    For Each Wrbk In Workbooks
        If Left(Wrbk.Name, 3) = "FAA" Then
            For Each Wsh In ActiveWorkbook.Worksheets
                Wsh.Activate
 
                Cells.FormatConditions.Delete
                For Each Shp In ActiveSheet.Shapes
                    Select Case Shp.Type
                        Case 1, 3 To 11, 13, 17, 20, 21, 24
                        ' action de suppression
                        Shp.Delete
                    End Select
                Next Shp
            Next Wsh
            'Stop
            'MsgBox "workbook ouvert : " & Wrbk.Name
            Sheets("Feuil1").Select
            ActiveWorkbook.SaveCopyAs Chem_Select & Wrbk.Name
 
            Wrbk.Close savechanges:=False
 
        End If
    Next Wrbk
 
End Sub

**Igloobel** · 08/01/2018, 12h34

Personne n'a une petite idée ou une piste pour résoudre mon problème ?

En tout cas bonne année à tous

**Phil'oche** · 09/01/2018, 12h39

Bonjour et bonne année également,

Comme tu le pressentais, il y a en effet un confusion...

Essaye :

Code :

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

1
2
3
4
5
6
    'je suppose que mon problème est ici
    For Each Wrbk In Workbooks
        Debug.Print Wrbk.Name
        Debug.Print ActiveWorkbook.Name
 
        If Left(Wrbk.Name, 3) = "FAA" Then

Et je pense que tu trouveras la réponse toi-même !

**Igloobel** · 21/02/2018, 13h30

Bonjour à tous,

Petit déterrage du fil

j'ai fais comme tu as dis Phil'oche, et effectivement j'ai changer "ActiveWorkbook" par "Wrbk" et cela marche très bien

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
    For Each Wrbk In Workbooks
        If Left(Wrbk.Name, 3) = "FAA" Or Left(Wrbk.Name, 3) = "EEA" Then
            For Each Wsh In ActiveWorkbook.Worksheets
                Wsh.Activate
 
                Cells.FormatConditions.Delete
                For Each Shp In ActiveSheet.Shapes
                    Select Case Shp.Type
                        Case 1, 3 To 11, 13, 17, 20, 21, 24
                        ' action de suppression
                        Shp.Delete
                    End Select
                Next Shp
            Next Wsh
            'Stop
            'MsgBox "workbook ouvert : " & Wrbk.Name
            Sheets("Feuil1").Select
            'ActiveWorkbook.SaveCopyAs Chem_Select & Wrbk.Name
            Wrbk.SaveCopyAs Chem_Select & Wrbk.Name
 
            Wrbk.Close savechanges:=False
 
        End If
    Next Wrbk

Je pensais (à tord) qu'un For Each activait d'office le classeur. Force est de constater que non.

j'ai bien apprecié ta façon de me montrer comment voir par moi-même où était le problème

merci Phil'oche

gestion de Classeurs parFile Dialog avec savegarde sur autre dossier [XL-2010]

Macros et VBA Excel

Discussions similaires

Partager

Partager