accelerer macro lecture ecriture cellule nommée autres fichiers

**jojo_peter** · 07/06/2016, 09h44

Bonjour,

J'ai un fichier base de données (A) et plein de fichiers sources (B1, B2, B3 ...)
J'ai écrit une macro qui ouvre l'un après l'autre des fichiers XLS d'un répertoire choisie par l'utilisateur.
La macro test ensuite si les cellules nommées indiqué dans le fichier A dans un onglet dédié sont dans le fichier (disons B1) que l'on vient d'ouvrir. Si c'est le cas, on copie le nom de la cellule nommée et sa valeur. Ensuite j'applique un petit traitement pour séparer en colonne certaines données extraites

Cela fonctionne mais c'est assez lent. (gros fichiers B1, de nombreuses cellules nommées dans B1 et beaucoup de fichiers à ouvrir).

Je sais, on est pas obligé d'ouvrir - refermer les fichiers avec Excel (merci ADO) sauf que comme j'ai échoué à m'en servir, j'ai choisi cette ouverture / fermeture de fichier.

Je pense qu'au niveau des boucles, il y a surrement mieux a faire ....
A la vu de mon code (perfectible, c'est clair), quelqu'un aurait il une idée pour l’accélérer ?

Merci beaucoup

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
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
 
Sub recup_noms_cellules_nommeesCF() 'recupere toutes les cellules nommées indiqué dans onglet CF
On Error Resume Next 'permet de continuer
 
Dim Dossier As Object
Dim Fichiers As Object
Dim fichier As Object
Dim Nom_Dossier As String
Dim système As Object
Dim Nom_Fichier As String
Dim wkfinal As Workbook
Set wkfinal = ThisWorkbook
 
If MsgBox("Etes-vous certain de vouloir ajouter des cellules nommées provenant de fichiers Comptes Financiers (CF) ?", vbYesNo, "Demande de confirmation") = vbYes Then
 
 
Nom_Dossier = SelDossier("F:\docFlo\www\")
Set système = CreateObject("Scripting.FileSystemObject")
Set Dossier = système.GetFolder(Nom_Dossier)
Set Fichiers = Dossier.Files
 
MsgBox ("Nombre de fiche dans le repertoire : " & NombreFichiers(Nom_Dossier))
Dim N As Name
    Dim PlageNom As Range
    Dim i As Byte
    Dim NumLigne As Byte
 
 
For Each fichier In Fichiers
 
Application.ScreenUpdating = False
 
 
Set FL_Data2 = ThisWorkbook.Worksheets("DATA2")
 
Nom_Fichier = Nom_Dossier & "\" & fichier.Name
 
 
Workbooks.Open Filename:=Nom_Fichier
 
Application.DisplayAlerts = False
Application.DisplayStatusBar = False
Application.Calculation = xlManual
Application.EnableEvents = False
Application.DisplayPageBreaks = False
 
Dim Fichier_courant As Workbook
Dim Onglet_courrant As Worksheet
 
 
 
    On Error Resume Next
 
 
 
 
Dim FL1 As Worksheet, NoCol As Integer
Dim NoLig As Long, Var As Variant
    Set FL1 = wkfinal.Sheets("CF_Data")
    NoCol = 2 'lecture de la colonne 1
 
 
    For NoLig = 2 To Split(FL1.UsedRange.Address, "$")(4)
        Var = FL1.Cells(NoLig, NoCol)
 
    If Not IsEmpty(Var) Then
 
    'If PlageNom.Value = Var Then 'And PlageNom.Value <> "" Then
 
k = Var
 
'MsgBox k
 
Z = Range(Var).RefersToRange.Value
'MsgBox Z
 
If FL_Data2.Range("Data2").Value <> "" Then
                derligne = FL_Data2.Range("A65536").End(xlUp).Row + 1
            Else
                derligne = FL_Data2.Range("A65536").End(xlUp).Row
            End If
 
 
wkfinal.Sheets("DATA2").Cells(derligne, 1).Value = fichier.Name
wkfinal.Sheets("DATA2").Cells(derligne, 2).Value = Var
wkfinal.Sheets("DATA2").Cells(derligne, 3).Value = Range(Var).Value
 
'******************************* complétude de la colonne 4 = N° Finess
wkfinal.Sheets("DATA2").Cells(derligne, 4).Value = Finess(fichier.Name)
 
 
'******************************* complétude de la colonne 5 = Type document
wkfinal.Sheets("DATA2").Cells(derligne, 5).Value = Left(fichier.Name, InStr(fichier.Name, "_") - 1)
 
 
'******************************* complétude de la colonne 6 = N° Année
'MsgBox Mid(fichier.Name, 1, (WorksheetFunction.Substitute("_", fichier.Name, 6)) - 1)
wkfinal.Sheets("DATA2").Cells(derligne, 6).Value = Right(Mid(fichier.Name, 1, (Application.WorksheetFunction.Find("_", fichier.Name, 6)) - 1), 4)
 
 
 
'******************************* colonne 7 = Source de la cellule nommée
If wkfinal.Sheets("DATA2").Cells(derligne, 5).Value = "CF" Then
wkfinal.Sheets("DATA2").Cells(derligne, 7).Value = WorksheetFunction.VLookup(Var, Sheets("CF_Data").Range("B2:c200"), 2, False)
End If
 
If wkfinal.Sheets("DATA2").Cells(derligne, 5).Value = "EPRD" Then
wkfinal.Sheets("DATA2").Cells(derligne, 7).Value = WorksheetFunction.VLookup(Var, Sheets("EPRD_Data").Range("B2:c200"), 2, False)
End If
 
If wkfinal.Sheets("DATA2").Cells(derligne, 5).Value = "RIA1" Then
wkfinal.Sheets("DATA2").Cells(derligne, 7).Value = WorksheetFunction.VLookup(Var, Sheets("RIA1_Data").Range("B2:c200"), 2, False)
End If
 
If wkfinal.Sheets("DATA2").Cells(derligne, 5).Value = "RIA2" Then
wkfinal.Sheets("DATA2").Cells(derligne, 7).Value = WorksheetFunction.VLookup(Var, Sheets("RIA2_Data").Range("B2:c200"), 2, False)
End If
 
If wkfinal.Sheets("DATA2").Cells(derligne, 5).Value = "RIA3" Then
wkfinal.Sheets("DATA2").Cells(derligne, 7).Value = WorksheetFunction.VLookup(Var, Sheets("RIA1_Data").Range("B2:c200"), 2, False)
End If
 
 
 
'******************************* complétude de la colonne 8 = N° colonne
 
If wkfinal.Sheets("DATA2").Cells(derligne, 5).Value = "CF" Then
wkfinal.Sheets("DATA2").Cells(derligne, 8).Value = WorksheetFunction.VLookup(Var, Sheets("CF_Data").Range("B2:D200"), 3, False)
End If
 
If wkfinal.Sheets("DATA2").Cells(derligne, 5).Value = "EPRD" Then
wkfinal.Sheets("DATA2").Cells(derligne, 8).Value = WorksheetFunction.VLookup(Var, Sheets("EPRD_Data").Range("B2:D200"), 3, False)
End If
 
If wkfinal.Sheets("DATA2").Cells(derligne, 5).Value = "RIA1" Then
wkfinal.Sheets("DATA2").Cells(derligne, 8).Value = WorksheetFunction.VLookup(Var, Sheets("RIA1_Data").Range("B2:D200"), 3, False)
End If
 
If wkfinal.Sheets("DATA2").Cells(derligne, 5).Value = "RIA2" Then
wkfinal.Sheets("DATA2").Cells(derligne, 8).Value = WorksheetFunction.VLookup(Var, Sheets("RIA2_Data").Range("B2:D200"), 3, False)
End If
 
If wkfinal.Sheets("DATA2").Cells(derligne, 5).Value = "RIA3" Then
wkfinal.Sheets("DATA2").Cells(derligne, 8).Value = WorksheetFunction.VLookup(Var, Sheets("RIA3_Data").Range("B2:D200"), 3, False)
End If
 
            End If
 
             Next
 
 
 ActiveWorkbook.Close
 
 
Set FL1 = Nothing
Next 'fichier
Application.ScreenUpdating = True
Application.DisplayAlerts = True
 
Application.DisplayStatusBar = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
Application.DisplayPageBreaks = True
 
End If
End Sub

**Al__22** · 07/06/2016, 10h01

Déjà tu peux commencer en rajoutant ceci :

Code :

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

1
2
Application.EnableEvents = False
Application.EnableAnimations = False

Sans oublier de les réactiver à la fin de la macro

Pour le reste faut que je prenne le temps de lire la macro ^^

EDIT : vérifie aussi que tu as coché Microsoft Scripting Runtime dans Outils>Références

**thebenoit59** · 07/06/2016, 10h21

Bonjour Jojo, bonjour Al.

Peux-tu expliquer à quoi sert exactement ton code ?
Je pense qu'il y a possibilités de le simplifier pour qu'il soit plus fluide et rapide.

**jojo_peter** · 07/06/2016, 10h36

Bonjour,

Merci Al pour la réponse.

Application.EnableEvents = False, celui la j'y ai pensé
Merci pour Application.EnableAnimations, c'est vrai que celui ci, j'y avais pas songé.

alors l'explication du code :
1. je permet à l'utilisateur de choisir un repertoire avec

Code :

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

système.GetFolder(Nom_Dossier)

2. au sein de ce repertoire, j'ouvre chaque fichier l'un après l'autre
3. pour chaque fichier ouvert, je vérifie si dans la liste de ces cellules nommées, il y a celle qui sont dans l'onglet CF_Data (mais pour ça, je fais une boucle pour récupérer toutes les cellules nommées de cet onglet) avec l'instruction

Code :

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

1
2
3
4
5
6
 Set FL1 = wkfinal.Sheets("CF_Data")
    NoCol = 2 'lecture de la colonne 1
 
 
    For NoLig = 2 To Split(FL1.UsedRange.Address, "$")(4)
        Var = FL1.Cells(NoLig, NoCol)

4. je test la dernière ligne de mon onglet qui me servira de base de données (data 2) avec

Code :

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

1
2
3
4
5
If FL_Data2.Range("Data2").Value <> "" Then
                derligne = FL_Data2.Range("A65536").End(xlUp).Row + 1
            Else
                derligne = FL_Data2.Range("A65536").End(xlUp).Row
            End If

5. puis je colle les données qui m'interessent dans data2:

Code :

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

1
2
3
wkfinal.Sheets("DATA2").Cells(derligne, 1).Value = fichier.Name 'nom du fichier
wkfinal.Sheets("DATA2").Cells(derligne, 2).Value = Var 'nom cellule nommée
wkfinal.Sheets("DATA2").Cells(derligne, 3).Value = Range(Var).Value   'valeur de la cellule nommée

6. un peu de retraitement pour splitter le nom du fichier et faire un recherchev

7. je ferme le fichier et passe au fichier suivant

Code :

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

1
2
3
 
ActiveWorkbook.Close   
Next

**RyuAutodidacte** · 07/06/2016, 10h51

Bonjour,
concernant les ThisWorkbook, je pense que tu devrais réservé ThisWorkbook juste pour le fichier maitre et mettre
Workbooks(Nom_du_fichier) pour les autres que tu ouvres et fermes, cela peut se faire automatiquement => modif du code
si l'on peut éviter de mettre des set quand c'est possible ...

Code :

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

 Split(FL1.UsedRange.Address, "$")(4)

peut s'écrire :

Code :

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

FL1.UsedRange.Rows.Count

Tous les :

Code :

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

1
2
wkfinal.Sheets("DATA2").Cells(derligne, 1).Value = fichier.Name
Etc ...

peuvent se mettent dan un with

Code :

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

1
2
3
4
5
With wkfinal.Sheets("DATA2")
.Cells(derligne, 1).Value = fichier.Name
...
...
End with

Cela évite de répéter et au moins on y est une fois pour toute dans wkfinal.Sheets("DATA2")

**Al__22** · 07/06/2016, 11h14

Tu peux aussi utiliser un dictionnaire pour vérifier tes valeurs dans tes colonnes :

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
Dim dico As New Dictionary
dico.Add 1, fichier.Name
dico.Add 2, Var
dico.Add 3, Range(Var).Value
dico.Add 4, Finess(fichier.Name)
dico.Add 5, Left(fichier.Name, InStr(fichier.Name, "_") - 1)
dico.Add 6, Right(Mid(fichier.Name, 1, (Application.WorksheetFunction.Find("_", fichier.Name, 6)) - 1), 4)
dico.Add "CF", WorksheetFunction.VLookup(Var, Sheets("CF_Data").Range("B2:c200"), 2, False)
dico.Add "EPRD", WorksheetFunction.VLookup(Var, Sheets("EPRD_Data").Range("B2:C200"), 2, False)
dico.Add "RIA1", WorksheetFunction.VLookup(Var, Sheets("RIA1_Data").Range("B2:C200"), 2, False)
dico.Add "RIA2", WorksheetFunction.VLookup(Var, Sheets("RIA2_Data").Range("B2:C200"), 2, False)
dico.Add "RIA3", WorksheetFunction.VLookup(Var, Sheets("RIA1_Data").Range("B2:C200"), 2, False)
 
wkfinal.Sheets("DATA2").Cells(derligne, 1).Value = dico(1)
wkfinal.Sheets("DATA2").Cells(derligne, 2).Value = dico(2)
wkfinal.Sheets("DATA2").Cells(derligne, 3).Value = dico(3)
 
'******************************* complétude de la colonne 4 = N° Finess
wkfinal.Sheets("DATA2").Cells(derligne, 4).Value = dico(4)
 
 
'******************************* complétude de la colonne 5 = Type document
wkfinal.Sheets("DATA2").Cells(derligne, 5).Value = dico(5)
 
 
'******************************* complétude de la colonne 6 = N° Année
'MsgBox Mid(fichier.Name, 1, (WorksheetFunction.Substitute("_", fichier.Name, 6)) - 1)
wkfinal.Sheets("DATA2").Cells(derligne, 6).Value = dico(6)
 
'******************************* colonne 7 = Source de la cellule nommée
wkfinal.Sheets("DATA2").Cells(derligne, 7).Value = dico(wkfinal.Sheets("DATA2").Cells(derligne, 5).Value)
 
'******************************* complétude de la colonne 8 = N° colonne
dico.Item("CF") = WorksheetFunction.VLookup(Var, Sheets("CF_Data").Range("B2:D200"), 3, False)
dico.Item("EPRD") = WorksheetFunction.VLookup(Var, Sheets("EPRD_Data").Range("B2:D200"), 3, False)
dico.Item("RIA1") = WorksheetFunction.VLookup(Var, Sheets("RIA1_Data").Range("B2:D200"), 3, False)
dico.Item("RIA2") = WorksheetFunction.VLookup(Var, Sheets("RIA2_Data").Range("B2:D200"), 3, False)
dico.Item("RIA3") = WorksheetFunction.VLookup(Var, Sheets("RIA3_Data").Range("B2:D200"), 3, False)
 
wkfinal.Sheets("DATA2").Cells(derligne, 8).Value = dico(wkfinal.Sheets("DATA2").Cells(derligne, 5).Value)
 
End If
 
Set dico = Nothing: Next

**jeanmidudu** · 07/06/2016, 11h15

Quelques petites observations :

- Evite au maximum d'utilise des caractères spéciaux ou accentuations dans tes variables :

Code :

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

Dim système As Object

- Essaye au maximum de déclarer tes variables dès le départ de ta sub (Tu fais plusieurs instructions avant de faire certaines déclarations)
- Utilise des WITH (pas seulement pour wkfinal.Sheets("DATA2") mais aussi dès que tu as pas mal d'instructions), par exemple :

Code :

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

1
2
3
4
5
6
7
8
 
With Application
        .DisplayAlerts = False
        .DisplayStatusBar = False
        .Calculation = xlManual
        .EnableEvents = False
        .DisplayPageBreaks = False
End With

- Utilise une variable pour effectuer récupérer la valeur dans wkfinal.Sheets("DATA2").cells() et effectue les if sur cette valeur (gain de temps considérable)
- Transforme tous tes if End If cherchant sur la même ligne et même colonne en if then elseIF

J'essaye d'épurer un peu ton code et je te le renvoie.

2 possibilités d'amélioration (à toi de voir laquelle est la plus rapide), qui reprennent aussi les idées des autres (je n'ai pas utilisé les dictionnaires par contre) :

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
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
 
Option Explicit
 
Sub recup_noms_cellules_nommeesCF() 'recupere toutes les cellules nommées indiqué dans onglet CF
On Error Resume Next 'permet de continuer
 
    Dim Dossier As Object, Fichiers As Object, fichier As Object, systeme As Object
    Dim Nom_Dossier As String, Nom_Fichier As String
    Dim wkfinal As Workbook, Fichier_courant As Workbook
    Dim N As Name
    Dim PlageNom As Range
    Dim i As Byte, NumLigne As Byte
    Dim Onglet_courrant As Worksheet, FL1 As Worksheet
    Dim NoCol As Integer
    Dim NoLig As Long
    Dim Var As Variant
    Dim valLigne As String
 
    Set wkfinal = ThisWorkbook
 
    If MsgBox("Etes-vous certain de vouloir ajouter des cellules nommées provenant de fichiers Comptes Financiers (CF) ?", vbYesNo, "Demande de confirmation") = vbYes Then
 
 
    Nom_Dossier = SelDossier("F:\docFlo\www\")
    Set système = CreateObject("Scripting.FileSystemObject")
    Set Dossier = système.GetFolder(Nom_Dossier)
    Set Fichiers = Dossier.Files
 
    MsgBox ("Nombre de fiche dans le repertoire : " & NombreFichiers(Nom_Dossier))
 
    For Each fichier In Fichiers
 
    Application.ScreenUpdating = False
 
 
    Set FL_Data2 = ThisWorkbook.Worksheets("DATA2")
 
    Nom_Fichier = Nom_Dossier & "\" & fichier.Name
 
    Workbooks.Open Filename:=Nom_Fichier
 
    With Application
        .DisplayAlerts = False
        .DisplayStatusBar = False
        .Calculation = xlManual
        .EnableEvents = False
        .DisplayPageBreaks = False
        .EnableAnimations = False
    End With
 
        On Error Resume Next
 
        Set FL1 = wkfinal.Sheets("CF_Data")
        NoCol = 2 'lecture de la colonne 1
 
        With wkfinal.Sheets("DATA2")
            For NoLig = 2 To FL1.UsedRange.Rows.Count
                Var = FL1.Cells(NoLig, NoCol)
 
                If Not IsEmpty(Var) Then
                    'If PlageNom.Value = Var Then 'And PlageNom.Value <> "" Then
 
                    k = Var
                    'MsgBox k
 
                    Z = Range(Var).RefersToRange.Value
                    'MsgBox Z
 
                        If FL_Data2.Range("Data2").Value <> "" Then
                            derligne = FL_Data2.Range("A65536").End(xlUp).Row + 1
                        Else
                            derligne = FL_Data2.Range("A65536").End(xlUp).Row
                        End If
 
                        .Cells(derligne, 1).Value = fichier.Name
                        .Cells(derligne, 2).Value = Var
                        .Cells(derligne, 3).Value = Range(Var).Value
 
    '******************************* complétude de la colonne 4 = N° Finess
                        .Cells(derligne, 4).Value = Finess(fichier.Name)
 
    '******************************* complétude de la colonne 5 = Type document
                        .Cells(derligne, 5).Value = Left(fichier.Name, InStr(fichier.Name, "_") - 1)
 
    '******************************* complétude de la colonne 6 = N° Année
    'MsgBox Mid(fichier.Name, 1, (WorksheetFunction.Substitute("_", fichier.Name, 6)) - 1)
                        .Cells(derligne, 6).Value = Right(Mid(fichier.Name, 1, (Application.WorksheetFunction.Find("_", fichier.Name, 6)) - 1), 4)
 
    '******************************* colonne 7 = Source de la cellule nommée
                        valLigne = .Cells(derligne, 5).Value
 
                        With wkfinal.Sheets("DATA2").Cells(derligne, 7).Value
                            If valLigne = "CF" Then
                                .Value = WorksheetFunction.VLookup(Var, Sheets("CF_Data").Range("B2:c200"), 2, False)
                            ElseIf valLigne = "EPRD" Then
                                .Value = WorksheetFunction.VLookup(Var, Sheets("EPRD_Data").Range("B2:c200"), 2, False)
                            ElseIf valLigne = "RIA1" Then
                                .Value = WorksheetFunction.VLookup(Var, Sheets("RIA1_Data").Range("B2:c200"), 2, False)
                            ElseIf valLigne = "RIA2" Then
                                .Value = WorksheetFunction.VLookup(Var, Sheets("RIA2_Data").Range("B2:c200"), 2, False)
                            ElseIf valLigne = "RIA3" Then
                                .Value = WorksheetFunction.VLookup(Var, Sheets("RIA1_Data").Range("B2:c200"), 2, False)
                            End If
                        End With
 
    '******************************* complétude de la colonne 8 = N° colonne
                        valLigne = .Cells(derligne, 5).Value
 
                        With wkfinal.Sheets("DATA2").Cells(derligne, 8).Value
                            If valLigne = "CF" Then
                                .Value = WorksheetFunction.VLookup(Var, Sheets("CF_Data").Range("B2:D200"), 2, False)
                            ElseIf valLigne = "EPRD" Then
                                .Value = WorksheetFunction.VLookup(Var, Sheets("EPRD_Data").Range("B2:D200"), 2, False)
                            ElseIf valLigne = "RIA1" Then
                                .Value = WorksheetFunction.VLookup(Var, Sheets("RIA1_Data").Range("B2:D200"), 2, False)
                            ElseIf valLigne = "RIA2" Then
                                .Value = WorksheetFunction.VLookup(Var, Sheets("RIA2_Data").Range("B2:D200"), 2, False)
                            ElseIf valLigne = "RIA3" Then
                                .Value = WorksheetFunction.VLookup(Var, Sheets("RIA1_Data").Range("B2:D200"), 2, False)
                            End If
                        End With
                    End If
                Next
 
                ActiveWorkbook.Close
                Set FL1 = Nothing
 
            Next 'fichier
        End With
 
    End If
 
    With Application
        .ScreenUpdating = True
        .DisplayAlerts = True
        .DisplayStatusBar = True
        .Calculation = xlCalculationAutomatic
        .EnableEvents = True
        .DisplayPageBreaks = True
        .EnableAnimations = True
    End With
 
End Sub

ou

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
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
 
 
Sub recup_noms_cellules_nommeesCF() 'recupere toutes les cellules nommées indiqué dans onglet CF
    On Error Resume Next 'permet de continuer
 
    Dim Dossier As Object, Fichiers As Object, fichier As Object, systeme As Object
    Dim Nom_Dossier As String, Nom_Fichier As String
    Dim wkfinal As Workbook, Fichier_courant As Workbook
    Dim N As Name
    Dim PlageNom As Range
    Dim i As Byte, NumLigne As Byte
    Dim Onglet_courrant As Worksheet, FL1 As Worksheet
    Dim NoCol As Integer
    Dim NoLig As Long
    Dim Var As Variant
    Dim valLigne As String
 
    Set wkfinal = ThisWorkbook
 
    If MsgBox("Etes-vous certain de vouloir ajouter des cellules nommées provenant de fichiers Comptes Financiers (CF) ?", vbYesNo, "Demande de confirmation") = vbYes Then
 
 
    Nom_Dossier = SelDossier("F:\docFlo\www\")
    Set système = CreateObject("Scripting.FileSystemObject")
    Set Dossier = système.GetFolder(Nom_Dossier)
    Set Fichiers = Dossier.Files
 
    MsgBox ("Nombre de fiche dans le repertoire : " & NombreFichiers(Nom_Dossier))
 
    For Each fichier In Fichiers
 
    Application.ScreenUpdating = False
 
 
    Set FL_Data2 = ThisWorkbook.Worksheets("DATA2")
 
    Nom_Fichier = Nom_Dossier & "\" & fichier.Name
 
    Workbooks.Open Filename:=Nom_Fichier
 
    With Application
        .DisplayAlerts = False
        .DisplayStatusBar = False
        .Calculation = xlManual
        .EnableEvents = False
        .DisplayPageBreaks = False
        .EnableAnimations = False
    End With
 
        On Error Resume Next
 
        Set FL1 = wkfinal.Sheets("CF_Data")
        NoCol = 2 'lecture de la colonne 1
 
        With wkfinal.Sheets("DATA2")
            For NoLig = 2 To FL1.UsedRange.Rows.Count
                Var = FL1.Cells(NoLig, NoCol)
 
                If Not IsEmpty(Var) Then
                    'If PlageNom.Value = Var Then 'And PlageNom.Value <> "" Then
 
                    k = Var
                    'MsgBox k
 
                    Z = Range(Var).RefersToRange.Value
                    'MsgBox Z
 
                        If FL_Data2.Range("Data2").Value <> "" Then
                            derligne = FL_Data2.Range("A65536").End(xlUp).Row + 1
                        Else
                            derligne = FL_Data2.Range("A65536").End(xlUp).Row
                        End If
 
                        .Cells(derligne, 1).Value = fichier.Name
                        .Cells(derligne, 2).Value = Var
                        .Cells(derligne, 3).Value = Range(Var).Value
 
    '******************************* complétude de la colonne 4 = N° Finess
                        .Cells(derligne, 4).Value = Finess(fichier.Name)
 
    '******************************* complétude de la colonne 5 = Type document
                        .Cells(derligne, 5).Value = Left(fichier.Name, InStr(fichier.Name, "_") - 1)
 
    '******************************* complétude de la colonne 6 = N° Année
    'MsgBox Mid(fichier.Name, 1, (WorksheetFunction.Substitute("_", fichier.Name, 6)) - 1)
                        .Cells(derligne, 6).Value = Right(Mid(fichier.Name, 1, (Application.WorksheetFunction.Find("_", fichier.Name, 6)) - 1), 4)
 
    '******************************* colonne 7 et 8 via un seul if
                        valLigne = .Cells(derligne, 5).Value
 
                        If valLigne = "CF" Then
                            .Cells(derligne, 7).Value = WorksheetFunction.VLookup(Var, Sheets("CF_Data").Range("B2:C200"), 2, False)
                            .Cells(derligne, 8).Value = WorksheetFunction.VLookup(Var, Sheets("CF_Data").Range("B2:D200"), 2, False)
                        ElseIf valLigne = "EPRD" Then
                            .Cells(derligne, 7).Value = WorksheetFunction.VLookup(Var, Sheets("EPRD_Data").Range("B2:C200"), 2, False)
                            .Cells(derligne, 8).Value = WorksheetFunction.VLookup(Var, Sheets("EPRD_Data").Range("B2:D200"), 2, False)
                        ElseIf valLigne = "RIA1" Then
                            .Cells(derligne, 7).Value = WorksheetFunction.VLookup(Var, Sheets("RIA1_Data").Range("B2:C200"), 2, False)
                            .Cells(derligne, 8).Value = WorksheetFunction.VLookup(Var, Sheets("RIA1_Data").Range("B2:D200"), 2, False)
                        ElseIf valLigne = "RIA2" Then
                            .Cells(derligne, 7).Value = WorksheetFunction.VLookup(Var, Sheets("RIA2_Data").Range("B2:C200"), 2, False)
                            .Cells(derligne, 8).Value = WorksheetFunction.VLookup(Var, Sheets("RIA2_Data").Range("B2:D200"), 2, False)
                        ElseIf valLigne = "RIA3" Then
                            .Cells(derligne, 7).Value = WorksheetFunction.VLookup(Var, Sheets("RIA1_Data").Range("B2:C200"), 2, False)
                            .Cells(derligne, 8).Value = WorksheetFunction.VLookup(Var, Sheets("RIA1_Data").Range("B2:D200"), 2, False)
                        End If
                    End If
                Next
 
                ActiveWorkbook.Close
                Set FL1 = Nothing
 
            Next 'fichier
        End With
    End If
 
    With Application
        .ScreenUpdating = True
        .DisplayAlerts = True
        .DisplayStatusBar = True
        .Calculation = xlCalculationAutomatic
        .EnableEvents = True
        .DisplayPageBreaks = True
        .EnableAnimations = True
    End With
 
End Sub

A toi de tester maintenant parmi toutes les propositions qui te sont faites laquelle est la plus rapide.

**Al__22** · 07/06/2016, 12h00

En reprenant le 1er code de jeanmidudu et en ajoutant le dico (oui j'y tiens à mon dictionnaire

mais en même temps ca évite toute les vérif du if qui prennent trop de temps à mon goût) :

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
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
 
Sub recup_noms_cellules_nommeesCF() 'recupere toutes les cellules nommées indiqué dans onglet CF
On Error Resume Next 'permet de continuer
 
    Dim Dossier As Object, Fichiers As Object, fichier As Object, systeme As Object
    Dim Nom_Dossier As String, Nom_Fichier As String
    Dim wkfinal As Workbook, Fichier_courant As Workbook
    Dim N As Name
    Dim PlageNom As Range
    Dim i As Byte, NumLigne As Byte
    Dim Onglet_courrant As Worksheet, FL1 As Worksheet
    Dim NoCol As Integer
    Dim NoLig As Long
    Dim Var As Variant
    Dim valLigne As String
    Dim dico1 As New Dictionary
    Dim dico2 As New Dictionary
 
    Set wkfinal = ThisWorkbook
 
    If MsgBox("Etes-vous certain de vouloir ajouter des cellules nommées provenant de fichiers Comptes Financiers (CF) ?", vbYesNo, "Demande de confirmation") = vbYes Then
 
 
    Nom_Dossier = SelDossier("F:\docFlo\www\")
    Set système = CreateObject("Scripting.FileSystemObject")
    Set Dossier = système.GetFolder(Nom_Dossier)
    Set Fichiers = Dossier.Files
 
    MsgBox ("Nombre de fiche dans le repertoire : " & NombreFichiers(Nom_Dossier))
 
    For Each fichier In Fichiers
 
    Application.ScreenUpdating = False
 
 
    Set FL_Data2 = ThisWorkbook.Worksheets("DATA2")
 
    Nom_Fichier = Nom_Dossier & "\" & fichier.Name
 
    Workbooks.Open Filename:=Nom_Fichier
 
    With Application
        .DisplayAlerts = False
        .DisplayStatusBar = False
        .Calculation = xlManual
        .EnableEvents = False
        .DisplayPageBreaks = False
        .EnableAnimations = False
    End With
 
dico1.Add "CF", WorksheetFunction.VLookup(Var, Sheets("CF_Data").Range("B2:C200"), 2, False)
dico1.Add "EPRD", WorksheetFunction.VLookup(Var, Sheets("EPRD_Data").Range("B2:C200"), 2, False)
dico1.Add "RIA1", WorksheetFunction.VLookup(Var, Sheets("RIA1_Data").Range("B2:C200"), 2, False)
dico1.Add "RIA2", WorksheetFunction.VLookup(Var, Sheets("RIA2_Data").Range("B2:C200"), 2, False)
dico1.Add "RIA3", WorksheetFunction.VLookup(Var, Sheets("RIA3_Data").Range("B2:C200"), 2, False)
dico2.Add "CF", WorksheetFunction.VLookup(Var, Sheets("CF_Data").Range("B2:C200"), 3, False)
dico2.Add "EPRD", WorksheetFunction.VLookup(Var, Sheets("EPRD_Data").Range("B2:C200"), 3, False)
dico2.Add "RIA1", WorksheetFunction.VLookup(Var, Sheets("RIA1_Data").Range("B2:C200"), 3, False)
dico2.Add "RIA2", WorksheetFunction.VLookup(Var, Sheets("RIA2_Data").Range("B2:C200"), 3, False)
dico2.Add "RIA3", WorksheetFunction.VLookup(Var, Sheets("RIA3_Data").Range("B2:C200"), 3, False)
 
        On Error Resume Next
 
        Set FL1 = wkfinal.Sheets("CF_Data")
        NoCol = 2 'lecture de la colonne 1
 
        With wkfinal.Sheets("DATA2")
            For NoLig = 2 To FL1.UsedRange.Rows.Count
                Var = FL1.Cells(NoLig, NoCol)
 
                If Not IsEmpty(Var) Then
                    'If PlageNom.Value = Var Then 'And PlageNom.Value <> "" Then
 
                    k = Var
                    'MsgBox k
 
                    Z = Range(Var).RefersToRange.Value
                    'MsgBox Z
 
                        If FL_Data2.Range("Data2").Value <> "" Then
                            derligne = FL_Data2.Range("A65536").End(xlUp).Row + 1
                        Else
                            derligne = FL_Data2.Range("A65536").End(xlUp).Row
                        End If
 
                        .Cells(derligne, 1).Value = fichier.Name
                        .Cells(derligne, 2).Value = Var
                        .Cells(derligne, 3).Value = Range(Var).Value
 
    '******************************* complétude de la colonne 4 = N° Finess
                        .Cells(derligne, 4).Value = Finess(fichier.Name)
 
    '******************************* complétude de la colonne 5 = Type document
                        .Cells(derligne, 5).Value = Left(fichier.Name, InStr(fichier.Name, "_") - 1)
 
    '******************************* complétude de la colonne 6 = N° Année
    'MsgBox Mid(fichier.Name, 1, (WorksheetFunction.Substitute("_", fichier.Name, 6)) - 1)
                        .Cells(derligne, 6).Value = Right(Mid(fichier.Name, 1, (Application.WorksheetFunction.Find("_", fichier.Name, 6)) - 1), 4)
 
    '******************************* colonne 7 = Source de la cellule nommée
                        valLigne = .Cells(derligne, 5).Value
 
                        wkfinal.Sheets("DATA2").Cells(derligne, 7).Value = dico1(valLigne)
 
    '******************************* complétude de la colonne 8 = N° colonne
                        valLigne = .Cells(derligne, 5).Value
 
                        wkfinal.Sheets("DATA2").Cells(derligne, 8).Value = dico2(valLigne)
 
                    End If
                Next
 
                ActiveWorkbook.Close
                Set FL1 = Nothing
 
            Next 'fichier
        End With
 
    End If
 
    With Application
        .ScreenUpdating = True
        .DisplayAlerts = True
        .DisplayStatusBar = True
        .Calculation = xlCalculationAutomatic
        .EnableEvents = True
        .DisplayPageBreaks = True
        .EnableAnimations = True
    End With
 
End Sub

accelerer macro lecture ecriture cellule nommée autres fichiers

Macros et VBA Excel

Vue hybride

Discussions similaires

Partager

Partager