Macro qui rame

**delph5931** · 06/12/2019, 11h52

Bonjour à tous,

Je rencontre un problème de macro ! Je ne suis pas une experte du tout
J'ai créé cette macro au fur et à mesure, elle permet en gros de convertir des fichiers csv, d'ajouter quelques formules, et de faire des copier-coller de colonne. Depuis que j'ai fait les dernières modifs, quand je la fait tourner, elle rame indéfiniment ...
Cela vient peut être du format de calcul automatique de mes formules : lorsque je l'active , la macro rame. Lorsque je le désactive, mes formules ne se mettent pas à jour.

Après des heures de recherche sans succès j'ai besoin de vous merci

Le code:

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
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
Sub Compliance_WK()
 
'afficher barre d'état
 
Application.DisplayStatusBar = True
 
'séparer mon fichier CSV en colonne
 
Sheets("scan training").Select
Columns("A:A").Select
Application.CutCopyMode = False
Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
Semicolon:=False, Comma:=True, Space:=False, Other:=False, FieldInfo _
:=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1), _
Array(7, 1), Array(8, 1), Array(9, 1), Array(10, 1), Array(11, 1), Array(12, 1), Array(13, 1 _
), Array(14, 1), Array(15, 1), Array(16, 1), Array(17, 1), Array(18, 1)), _
TrailingMinusNumbers:=True
 
'séparer colonne nom,prénom en 2 colonnes nom et prénom
 
Application.DisplayAlerts = False
 
Sheets("scan training").Select
 
Columns("B:B").Select
Selection.TextToColumns Destination:=Range("B1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
Semicolon:=False, Comma:=True, Space:=False, Other:=False, FieldInfo _
:=Array(Array(1, 1), Array(2, 1)), TrailingMinusNumbers:=Tru
 
Application.DisplayAlerts = True
 
' renomme colonne B1
 
Sheets("scan training").Select
Range("C1") = "Adresse"
 
' HRextract Macro
' HR extract mise en forme données quicksight pour les intégrer dans le reporting ambassadeur
'
Sheets("HR extract").Select
'
Columns("A:A").Select
Application.CutCopyMode = False
Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
Semicolon:=False, Comma:=True, Space:=False, Other:=False, FieldInfo _
:=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1), _
Array(7, 1), Array(8, 1), Array(9, 1), Array(10, 1), Array(11, 1), Array(12, 1), Array(13, 1 _
), Array(14, 1), Array(15, 1), Array(16, 1), Array(17, 1), Array(18, 1), Array(19, 1), Array _
(20, 1), Array(21, 1), Array(22, 1), Array(23, 1), Array(24, 1), Array(25, 1), Array(26, 1), _
Array(27, 1), Array(28, 1), Array(29, 1), Array(30, 1), Array(31, 1), Array(32, 1), Array( _
33, 1), Array(34, 1), Array(35, 1), Array(36, 1), Array(37, 1), Array(38, 1), Array(39, 1), _
Array(40, 1)), TrailingMinusNumbers:=True
Columns("E:E").Select
Selection.NumberFormat = "m/d/yyyy"
Columns("P").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Range("P1").Select
ActiveCell.FormulaR1C1 = "DS"
Range("P2").Select
ActiveCell.FormulaR1C1 = "=LEFT(RC[-1],4)"
Range("P2").Select
Selection.AutoFill Destination:=Range("P210000")
Range("P210000").Select
 
'Supprimer_lignes_contiennent_pas_un_mot
 
For i = ActiveSheet.UsedRange.Rows.Count To 2 Step -1
If Not Cells(i, 23) Like "*Warehouse*" Then Rows(i).Delete
Next
 
'passer en mode auto uniquement mon onglet HR extract
 
Sheets("HR extract").Calculate
 
'intègre données HR extract dans la compliance WK
 
Range("P2").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets("Active Pool SA").Select
Range("B2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("HR extract").Select
ActiveWindow.SmallScroll Down:=-21
ActiveWindow.ScrollRow = 1039
ActiveWindow.ScrollRow = 1027
ActiveWindow.ScrollRow = 999
ActiveWindow.ScrollRow = 938
ActiveWindow.ScrollRow = 632
ActiveWindow.ScrollRow = 543
ActiveWindow.ScrollRow = 410
ActiveWindow.ScrollRow = 383
ActiveWindow.ScrollRow = 332
ActiveWindow.ScrollRow = 310
ActiveWindow.ScrollRow = 221
ActiveWindow.ScrollRow = 210
ActiveWindow.ScrollRow = 193
ActiveWindow.ScrollRow = 187
ActiveWindow.ScrollRow = 176
ActiveWindow.ScrollRow = 165
ActiveWindow.ScrollRow = 83
ActiveWindow.ScrollRow = 72
ActiveWindow.ScrollRow = 60
ActiveWindow.ScrollRow = 56
ActiveWindow.ScrollRow = 52
ActiveWindow.ScrollRow = 50
ActiveWindow.ScrollRow = 44
ActiveWindow.ScrollRow = 39
ActiveWindow.ScrollRow = 2
ActiveWindow.ScrollRow = 1
Range("D2").Select
Range(Selection, Selection.End(xlDown)).Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Active Pool SA").Select
Range("C2").Select
ActiveSheet.Paste
Sheets("HR extract").Select
ActiveWindow.SmallScroll Down:=-54
ActiveWindow.ScrollRow = 1016
ActiveWindow.ScrollRow = 1011
ActiveWindow.ScrollRow = 1007
ActiveWindow.ScrollRow = 1001
ActiveWindow.ScrollRow = 993
ActiveWindow.ScrollRow = 960
ActiveWindow.ScrollRow = 861
ActiveWindow.ScrollRow = 693
ActiveWindow.ScrollRow = 548
ActiveWindow.ScrollRow = 487
ActiveWindow.ScrollRow = 248
ActiveWindow.ScrollRow = 224
ActiveWindow.ScrollRow = 201
ActiveWindow.ScrollRow = 159
ActiveWindow.ScrollRow = 145
ActiveWindow.ScrollRow = 137
ActiveWindow.ScrollRow = 130
ActiveWindow.ScrollRow = 126
ActiveWindow.ScrollRow = 122
ActiveWindow.ScrollRow = 117
ActiveWindow.ScrollRow = 114
ActiveWindow.ScrollRow = 109
ActiveWindow.ScrollRow = 106
ActiveWindow.ScrollRow = 63
ActiveWindow.ScrollRow = 52
ActiveWindow.ScrollRow = 49
ActiveWindow.ScrollRow = 47
ActiveWindow.ScrollRow = 44
ActiveWindow.ScrollRow = 42
ActiveWindow.ScrollRow = 38
ActiveWindow.ScrollRow = 33
ActiveWindow.ScrollRow = 32
ActiveWindow.ScrollRow = 27
ActiveWindow.ScrollRow = 25
ActiveWindow.ScrollRow = 24
ActiveWindow.ScrollRow = 22
ActiveWindow.ScrollRow = 21
ActiveWindow.ScrollRow = 19
ActiveWindow.ScrollRow = 18
ActiveWindow.ScrollRow = 16
ActiveWindow.ScrollRow = 15
ActiveWindow.ScrollRow = 13
ActiveWindow.ScrollRow = 11
ActiveWindow.ScrollRow = 10
ActiveWindow.ScrollRow = 8
ActiveWindow.ScrollRow = 7
ActiveWindow.ScrollRow = 5
ActiveWindow.ScrollRow = 4
ActiveWindow.ScrollRow = 2
ActiveWindow.ScrollRow = 1
Range("E2").Select
Range(Selection, Selection.End(xlDown)).Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Active Pool SA").Select
Range("G2").Select
ActiveSheet.Paste
 
'passer en mode auto
 
Application.Calculation = xlAutomatic
 
'Revenir à l'onglet de départ
 
Sheets("Compliance WK").Select
 
 
End Sub

**ARTURO83** · 06/12/2019, 18h37

Bonsoir,

De par le fait de ne pas connaître la structure de votre fichier, essayez ceci. (par prudence bien sûr, essayez sur une copie)

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
Sub Compliance_WK()
    Application.ScreenUpdating = False
    'afficher barre d'état
    Application.DisplayStatusBar = True
    'séparer mon fichier CSV en colonne
 
    Set f1 = Sheets("scan training")
    Set f2 = Sheets("HR extract")
    Set f3 = Sheets("Active Pool SA")
    Set f4 = Sheets("Compliance WK")
 
    f1.Columns(1).TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
    TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
    Semicolon:=False, Comma:=True, Space:=False, Other:=False, FieldInfo _
    :=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1), _
    Array(7, 1), Array(8, 1), Array(9, 1), Array(10, 1), Array(11, 1), Array(12, 1), Array(13, 1 _
    ), Array(14, 1), Array(15, 1), Array(16, 1), Array(17, 1), Array(18, 1)), _
    TrailingMinusNumbers:=True
 
    'séparer colonne nom,prénom en 2 colonnes nom et prénom
    Application.DisplayAlerts = False
    f1.Columns(2).TextToColumns Destination:=Range("B1"), DataType:=xlDelimited, _
    TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
    Semicolon:=False, Comma:=True, Space:=False, Other:=False, FieldInfo _
    :=Array(Array(1, 1), Array(2, 1)), TrailingMinusNumbers:=True
 
    Application.DisplayAlerts = True
    ' renomme colonne B1
 
    f1.Range("C1") = "Adresse"
    ' HRextract Macro
    ' HR extract mise en forme données quicksight pour les intégrer dans le reporting ambassadeur
    '
    f2.Columns(1).TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
    TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
    Semicolon:=False, Comma:=True, Space:=False, Other:=False, FieldInfo _
    :=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1), _
    Array(7, 1), Array(8, 1), Array(9, 1), Array(10, 1), Array(11, 1), Array(12, 1), Array(13, 1 _
    ), Array(14, 1), Array(15, 1), Array(16, 1), Array(17, 1), Array(18, 1), Array(19, 1), Array _
    (20, 1), Array(21, 1), Array(22, 1), Array(23, 1), Array(24, 1), Array(25, 1), Array(26, 1), _
    Array(27, 1), Array(28, 1), Array(29, 1), Array(30, 1), Array(31, 1), Array(32, 1), Array( _
    33, 1), Array(34, 1), Array(35, 1), Array(36, 1), Array(37, 1), Array(38, 1), Array(39, 1), _
    Array(40, 1)), TrailingMinusNumbers:=True
    f2.Columns("E:E").NumberFormat = "m/d/yyyy"
    f2.Columns("P").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    f2.Range("P1") = "DS"
    f2.Range("P2:P21000").FormulaR1C1 = "=LEFT(RC[-1],4)"
 
    'Supprimer_lignes_contiennent_pas_un_mot
    For i = f2.Range("W" & f2.Rows.Count) To 2 Step -1
        If Not f2.Cells(i, 23) Like "*Warehouse*" Then f2.Rows(i).Delete
    Next
 
    'passer en mode auto uniquement mon onglet HR extract
    f2.Calculate
 
    'intègre données HR extract dans la compliance WK
    f2.Range("P2", f2.Range("P" & f2.Rows.Count)).Copy Destination:=f3.[B2]
    f3.Columns(2).Value = f3.Columns(2).Value
    f2.Range("D2", f2.Range("D" & f2.Rows.Count)).Copy Destination:=f3.[C2]
    f2.Range("E2", f2.Range("E" & f2.Rows.Count)).Copy Destination:=f3.[G2]
 
    'passer en mode auto
    Application.Calculation = xlAutomatic
 
    'Revenir à l'onglet de départ
    f4.Select
    Set f1 = Nothing
    Set f2 = Nothing
    Set f3 = Nothing
    Set f4 = Nothing
End Sub

Cdlt

**delph5931** · 12/12/2019, 16h43

Bonjour,

Merci ça fonctionne !

La macro tourne en 5 mn ce qui est beaucoup mieux

En revanche ces lignes ne fonctionnent pas :

Code :

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

1
2
3
4
5
'Supprimer_lignes_contiennent_pas_un_mot
 
For i = ActiveSheet.UsedRange.Rows.Count To 2 Step -1
If Not Cells(i, 23) Like "*Warehouse*" Then Rows(i).Delete
Next

En gros je cherche à supprimer les lignes de la colonne W qui ne contiennent pas le mot "Warehouse", est ce que vous savez pourquoi ?

J'ai supprimé quelques lignes du code qui n'était plus adapté :

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
Sub Compliance_WK()
    Application.ScreenUpdating = False
 
    'séparer mon fichier CSV en colonne
 
    Set f1 = Sheets("scan training")
    Set f2 = Sheets("HR extract")
    Set f3 = Sheets("Active Pool SA")
    Set f4 = Sheets("Compliance WK")
 
    f1.Columns(1).TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
    TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
    Semicolon:=False, Comma:=True, Space:=False, Other:=False, FieldInfo _
    :=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1), _
    Array(7, 1), Array(8, 1), Array(9, 1), Array(10, 1), Array(11, 1), Array(12, 1), Array(13, 1 _
    ), Array(14, 1), Array(15, 1), Array(16, 1), Array(17, 1), Array(18, 1)), _
    TrailingMinusNumbers:=True
 
 
    f1.Range("C1") = "Adresse"
    ' HRextract Macro
    ' HR extract mise en forme données quicksight pour les intégrer dans le reporting ambassadeur
    '
    f2.Columns(1).TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
    TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
    Semicolon:=False, Comma:=True, Space:=False, Other:=False, FieldInfo _
    :=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1), _
    Array(7, 1), Array(8, 1), Array(9, 1), Array(10, 1), Array(11, 1), Array(12, 1), Array(13, 1 _
    ), Array(14, 1), Array(15, 1), Array(16, 1), Array(17, 1), Array(18, 1), Array(19, 1), Array _
    (20, 1), Array(21, 1), Array(22, 1), Array(23, 1), Array(24, 1), Array(25, 1), Array(26, 1), _
    Array(27, 1), Array(28, 1), Array(29, 1), Array(30, 1), Array(31, 1), Array(32, 1), Array( _
    33, 1), Array(34, 1), Array(35, 1), Array(36, 1), Array(37, 1), Array(38, 1), Array(39, 1), _
    Array(40, 1)), TrailingMinusNumbers:=True
    f2.Columns("E:E").NumberFormat = "m/d/yyyy"
    f2.Columns("P").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    f2.Range("P1") = "DS"
    f2.Range("P2:P21000").FormulaR1C1 = "=LEFT(RC[-1],4)"
 
    'Supprimer_lignes_contiennent_pas_un_mot
    For i = f2.Range("W" & f2.Rows.Count) To 2 Step -1
        If Not f2.Cells(i, 23) Like "*Warehouse*" Then f2.Rows(i).Delete
    Next
 
 
    'passer en mode auto
    Application.Calculation = xlAutomatic
 
    'Revenir à l'onglet de départ
    f4.Select
    Set f1 = Nothing
    Set f2 = Nothing
    Set f3 = Nothing
    Set f4 = Nothing
End Sub

Merci pour votre aide

**ARTURO83** · 12/12/2019, 18h11

Bonjour,

Essayez ceci

Code :

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

1
2
3
    For i = F2.Range("W" & Rows.Count).End(xlUp).Row To 2 Step -1
        If InStr(1, F2.Cells(i, 23), "Warehouse", 1) > 0 Then F2.Rows(i).Delete
    Next

Cdlt

**Qwazerty** · 12/12/2019, 19h12

^{Salut

Peux-tu nous donner un fichier modèle (sans données sensibles) et nous expliquer un peu ce que tu souhaites faire? Une macro qui prend 5mn c'est beaucoup.

++

Qwaz}

Macro qui rame

Macros et VBA Excel

Vue hybride

Discussions similaires

Partager

Partager