J'ai résolut mon problème de lenteur en utilisant :Bonjour j'ai résolu mon problème tout fonctionne bien voici le code:
j'ai mis NumColList ET NumColBase en integer en string cela fonctionne pas.
Cependant avec cette macro j'ai un problème de lenteur ... Il y a t'il un moyen d'amélioré ses performance ?
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 Public Feuillebase As String Public FeuilleList As String Public PlageBase As Range Public Plagetype As Range Public PlageList As Range Public NumColList As Long Public NumColBase As Long Public Types As String Sub actualisationlist() Call listTypeFTS Call listMaterielFTS Call listTacheFTS Call listVersionFTS Call listObservationFTS End Sub Sub listTypeFTS() Feuillebase = "Base de données" FeuilleList = "ListesFTS" Set Plagetype = ThisWorkbook.Sheets(Feuillebase).Range("C2:C" & Sheets(Feuillebase).[C1048576].End(xlUp).Row) Set PlageBase = ThisWorkbook.Sheets(Feuillebase).Range("C2:C" & Sheets(Feuillebase).[C1048576].End(xlUp).Row) Set PlageList = ThisWorkbook.Sheets(FeuilleList).Range("A2:A" & Sheets(FeuilleList).[A1048576].End(xlUp).Row) Types = "FT" Set MonTablo = ThisWorkbook.Sheets(FeuilleList).ListObjects("List_TypeFTS") NumColList = 1 NumColBase = 3 Call Incementationlist End Sub Sub listMaterielFTS() Feuillebase = "Base de données" FeuilleList = "ListesFTS" Set Plagetype = ThisWorkbook.Sheets(Feuillebase).Range("C2:C" & Sheets(Feuillebase).[C1048576].End(xlUp).Row) Set PlageBase = ThisWorkbook.Sheets(Feuillebase).Range("D2:D" & Sheets(Feuillebase).[D1048576].End(xlUp).Row) Set PlageList = ThisWorkbook.Sheets(FeuilleList).Range("B2:B" & Sheets(FeuilleList).[B1048576].End(xlUp).Row) Types = "FT" Set MonTablo = ThisWorkbook.Sheets(FeuilleList).ListObjects("List_MaterielFTS") NumColList = 2 NumColBase = 4 Call Incementationlist End Sub Sub listTacheFTS() Feuillebase = "Base de données" FeuilleList = "ListesFTS" Set Plagetype = ThisWorkbook.Sheets(Feuillebase).Range("C2:C" & Sheets(Feuillebase).[C1048576].End(xlUp).Row) Set PlageBase = ThisWorkbook.Sheets(Feuillebase).Range("F2:F" & Sheets(Feuillebase).[F1048576].End(xlUp).Row) Set PlageList = ThisWorkbook.Sheets(FeuilleList).Range("C2:C" & Sheets(FeuilleList).[C1048576].End(xlUp).Row) Types = "FT" Set MonTablo = ThisWorkbook.Sheets(FeuilleList).ListObjects("List_TacheFTS") NumColList = 3 NumColBase = 6 Call Incementationlist End Sub Sub listVersionFTS() Feuillebase = "Base de données" FeuilleList = "ListesFTS" Set Plagetype = ThisWorkbook.Sheets(Feuillebase).Range("C2:C" & Sheets(Feuillebase).[C1048576].End(xlUp).Row) Set PlageBase = ThisWorkbook.Sheets(Feuillebase).Range("G2:G" & Sheets(Feuillebase).[G1048576].End(xlUp).Row) Set PlageList = ThisWorkbook.Sheets(FeuilleList).Range("D2:D" & Sheets(FeuilleList).[D1048576].End(xlUp).Row) Types = "FT" Set MonTablo = ThisWorkbook.Sheets(FeuilleList).ListObjects("List_VersionFTS") NumColList = 4 NumColBase = 7 Call Incementationlist End Sub Sub listObservationFTS() Feuillebase = "Base de données" FeuilleList = "ListesFTS" Set Plagetype = ThisWorkbook.Sheets(Feuillebase).Range("C2:C" & Sheets(Feuillebase).[C1048576].End(xlUp).Row) Set PlageBase = ThisWorkbook.Sheets(Feuillebase).Range("H2:H" & Sheets(Feuillebase).[H1048576].End(xlUp).Row) Set PlageList = ThisWorkbook.Sheets(FeuilleList).Range("E2:E" & Sheets(FeuilleList).[E1048576].End(xlUp).Row) Types = "FT" Set MonTablo = ThisWorkbook.Sheets(FeuilleList).ListObjects("List_ObservationFTS") NumColList = 5 NumColBase = 8 Call Incementationlist End Sub Sub Incementationlist() Dim LList As Object Dim X As String Dim Cel As Range Dim V1 As String Dim V2 As String Dim D As String Dim c As Range Dim Clear As String Dim num As Long Dim i As Long Set LList = CreateObject("Scripting.Dictionary") 'Crée le répertoire LList.CompareMode = TextCompare 'On rend le dictionnaire insensible aux majuscules minuscules Clear = ThisWorkbook.Sheets(FeuilleList).Cells(Rows.Count, NumColList).End(xlUp).Row - 1 If ThisWorkbook.Sheets(FeuilleList).Cells(2, NumColList).Value <> "" Then For i = Clear To 1 Step -1 MonTablo.ListRows(i).Delete Next i End If For Each Cel In Plagetype 'Pour tout les cellules de la colonne indiqué X = Cel.Row 'Prend le numéro de ligne de la cellule en cours de traitement V1 = ThisWorkbook.Sheets(Feuillebase).Cells(X, 3).Value ' V prend la valeur de la cellules indiqué If InStr(1, V1, Types) <> 0 Then V2 = ThisWorkbook.Sheets(Feuillebase).Cells(X, NumColBase).Value Set c = PlageList.Find(V2, LookIn:=xlValues, lookat:=xlWhole) ' C prend la valeur Nothing si il ne trouve rien sinon la valeur de la case 'Si la valeur de la celulle n'existe pas dans le disctionnaire et qu'elle est différente de vide alors la copier dans le dictionnaire If c Is Nothing And Not LList.Exists(V2) Then ' Si C est rien et qu'il n'existe pas V dans la list LList alors D = ThisWorkbook.Sheets(FeuilleList).Cells(Rows.Count, NumColList).End(xlUp).Row + 1 ' D prend la valeur de la dernier ligne disponible dans la plage 'ThisWorkbook.Sheets(FeuilleList).Cells(D, NumColList).Value = V2 'La cellule indique en D prend la valeur de V LList.Add V2, V2 'ajoue de V dans la liste LList End If 'fin de si End If Next Cel 'cellule suivante i = 2 For Each Item In LList ThisWorkbook.Sheets(FeuilleList).Cells(i, NumColList).Value = Item i = i + 1 Next Item 'Début tris alphabétique de la list Feuille = FeuilleList 'défini que feuille est "Toutes les Listes" MaColonne = Sheets(Feuille).Cells(1, NumColList).Value 'Défini que la colonne est en B1 Call TriAlpha 'appel la macro TriAlpha 'Fin tris alphabétique de la list End Sub 'fin de macro
Cordialement,
Passepartout007
Ce code pour supprimer les éléments :
et ce code pour les ajouter :
Code : Sélectionner tout - Visualiser dans une fenêtre à part
1
2
3 With MonTablo If .ListRows.Count > 2 Then .DataBodyRange.Resize(.ListRows.Count - 1, .ListColumns.Count).Offset(1, 0).Delete End With
Voila voila ,
Code : Sélectionner tout - Visualiser dans une fenêtre à part
1
2
3
4
5 With MonTablo .Resize (.Parent.Range(.Range.Cells(1, 1).Address, .Range.Cells(1, 1).Offset(MonDico.Count, .ListColumns.Count - 1))) .ListColumns("Nomdemacolonne").DataBodyRange.Value = Application.Transpose(MonDico.keys) End With
Merci encore
Partager