Se connecter avec
S'enregistrer | Connectez-vous
Votre question

Extraire des données de plusieurs feuilles avec deux conditions vers une autre feuille

Dernière réponse : dans Programmation
Partagez
1 Février 2012 11:32:52

Bonjour,

J'ai enregistrée une macro afin de pouvoir extraire des données de plusieurs feuilles vers une seule si une données d'une colonne correspond à deux conditions différentes.
Bon, je ne sai pas si je m'explique bien mais voilà :
j'ai une base de données de documents classés par feuilles : j'ai donc une feuille "Ancien systeme", une feuille "Procedure", une feuille "Instruction", une feuille "Formulaire" et une feuille "Liste".
Chacune des feuilles contiennent les même informations au niveau des colonnes : "A=Référence", "B=Ancienne Référence", "C=TITRE", "E=Rédacteur", "F=Service Emetteur".....plein d'autres colonnes mais qui ne m'intéresse pas dans l'extraction....et enfin, "S=Date de fin de validité" et "T= Obsolete", sauf pour la feuille "Ancien systeme" dont la colonne A est vide!
Je souhaite donc extraite les données des colonnes que j'ai nommés ci-dessus vers une autre feuille que j'appellerais "liste des obso" en donnant comme conditions que "OBSO" ou "FUTUR OBSO" soit dans la colonne "T=Obsolete" et que chaque extraction arrive à la suite de l'autre.
C'est à dire que l'extraction qui sera faite de la feuille ancien systeme soit en premier, que l'extraction de la feuille Procedure arrive à la première ligne vide et ainsi de suite.

  1. Sub Macro1()
  2. '
  3. ' Macro1 Macro
  4. '
  5.  
  6. '
  7. Rows("5:500").Select
  8. Application.CutCopyMode = False
  9. Selection.Delete Shift:=xlUp
  10. Range("A5").Select
  11. Sheets("Ancien Systeme").Select
  12. ActiveSheet.Range("$B$1:$W$10").AutoFilter Field:=18, Criteria1:="<>"
  13. ActiveWindow.SmallScroll Down:=-18
  14. ActiveWindow.SmallScroll ToRight:=-3
  15. Range("R3:S10").Select
  16. ActiveWindow.SmallScroll ToRight:=-9
  17. Range("R3:S10,B3:E10").Select
  18. Range("E3").Activate
  19. Selection.Copy
  20. Sheets("Liste des Obso").Select
  21. Range("B5").Select
  22. ActiveSheet.Paste
  23. Range("A12:G12").Select
  24. Application.CutCopyMode = False
  25. Selection.Borders(xlDiagonalDown).LineStyle = xlNone
  26. Selection.Borders(xlDiagonalUp).LineStyle = xlNone
  27. With Selection.Borders(xlEdgeLeft)
  28. .LineStyle = xlContinuous
  29. .ColorIndex = 0
  30. .TintAndShade = 0
  31. .Weight = xlThin
  32. End With
  33. With Selection.Borders(xlEdgeTop)
  34. .LineStyle = xlContinuous
  35. .ColorIndex = 0
  36. .TintAndShade = 0
  37. .Weight = xlThin
  38. End With
  39. With Selection.Borders(xlEdgeBottom)
  40. .LineStyle = xlContinuous
  41. .ColorIndex = 0
  42. .TintAndShade = 0
  43. .Weight = xlThin
  44. End With
  45. With Selection.Borders(xlEdgeRight)
  46. .LineStyle = xlContinuous
  47. .ColorIndex = 0
  48. .TintAndShade = 0
  49. .Weight = xlThin
  50. End With
  51. Selection.Borders(xlInsideVertical).LineStyle = xlNone
  52. Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
  53. With Selection.Interior
  54. .Pattern = xlSolid
  55. .PatternColorIndex = xlAutomatic
  56. .ThemeColor = xlThemeColorAccent5
  57. .TintAndShade = 0.799981688894314
  58. .PatternTintAndShade = 0
  59. End With
  60. Sheets("Ancien Systeme").Select
  61. ActiveWindow.ScrollColumn = 5
  62. ActiveWindow.ScrollColumn = 6
  63. ActiveWindow.ScrollColumn = 7
  64. ActiveWindow.ScrollColumn = 11
  65. ActiveWindow.ScrollColumn = 12
  66. ActiveWindow.ScrollColumn = 13
  67. ActiveWindow.ScrollColumn = 14
  68. ActiveWindow.ScrollColumn = 15
  69. ActiveWindow.ScrollColumn = 16
  70. ActiveWindow.ScrollColumn = 17
  71. ActiveWindow.ScrollColumn = 18
  72. ActiveWindow.ScrollColumn = 19
  73. ActiveSheet.Range("$B$1:$W$10").AutoFilter Field:=18
  74. Sheets("Procedure").Select
  75. ActiveSheet.Range("$A$1:$X$293").AutoFilter Field:=20, Criteria1:="<>"
  76. ActiveWindow.SmallScroll Down:=-24
  77. Range("S6:T267").Select
  78. ActiveWindow.ScrollColumn = 16
  79. ActiveWindow.ScrollColumn = 15
  80. ActiveWindow.ScrollColumn = 14
  81. ActiveWindow.ScrollColumn = 13
  82. ActiveWindow.ScrollColumn = 12
  83. ActiveWindow.ScrollColumn = 11
  84. ActiveWindow.ScrollColumn = 10
  85. ActiveWindow.ScrollColumn = 9
  86. ActiveWindow.ScrollColumn = 8
  87. ActiveWindow.ScrollColumn = 7
  88. ActiveWindow.ScrollColumn = 6
  89. ActiveWindow.ScrollColumn = 5
  90. ActiveWindow.ScrollColumn = 3
  91. ActiveWindow.ScrollColumn = 2
  92. ActiveWindow.ScrollRow = 175
  93. ActiveWindow.ScrollRow = 159
  94. ActiveWindow.ScrollRow = 152
  95. ActiveWindow.ScrollRow = 149
  96. ActiveWindow.ScrollRow = 132
  97. ActiveWindow.ScrollRow = 119
  98. ActiveWindow.ScrollRow = 113
  99. ActiveWindow.ScrollRow = 111
  100. ActiveWindow.ScrollRow = 108
  101. ActiveWindow.ScrollRow = 101
  102. ActiveWindow.ScrollRow = 98
  103. ActiveWindow.ScrollRow = 93
  104. ActiveWindow.ScrollRow = 89
  105. ActiveWindow.ScrollRow = 88
  106. ActiveWindow.ScrollRow = 78
  107. ActiveWindow.ScrollRow = 68
  108. ActiveWindow.ScrollRow = 67
  109. ActiveWindow.ScrollRow = 61
  110. ActiveWindow.ScrollRow = 56
  111. ActiveWindow.ScrollRow = 54
  112. ActiveWindow.ScrollRow = 49
  113. ActiveWindow.ScrollRow = 47
  114. ActiveWindow.ScrollRow = 43
  115. ActiveWindow.ScrollRow = 37
  116. ActiveWindow.ScrollRow = 28
  117. ActiveWindow.ScrollRow = 25
  118. ActiveWindow.ScrollRow = 17
  119. ActiveWindow.ScrollRow = 6
  120. ActiveWindow.SmallScroll Down:=-9
  121. Range("A6:F267").Select
  122. Range("F6").Activate
  123. ActiveWindow.ScrollColumn = 3
  124. ActiveWindow.ScrollColumn = 4
  125. ActiveWindow.ScrollColumn = 6
  126. ActiveWindow.ScrollColumn = 7
  127. ActiveWindow.ScrollColumn = 8
  128. ActiveWindow.ScrollColumn = 9
  129. ActiveWindow.ScrollColumn = 10
  130. ActiveWindow.ScrollColumn = 11
  131. ActiveWindow.ScrollColumn = 12
  132. ActiveWindow.ScrollRow = 175
  133. ActiveWindow.ScrollRow = 158
  134. ActiveWindow.ScrollRow = 151
  135. ActiveWindow.ScrollRow = 150
  136. ActiveWindow.ScrollRow = 132
  137. ActiveWindow.ScrollRow = 122
  138. ActiveWindow.ScrollRow = 113
  139. ActiveWindow.ScrollRow = 111
  140. ActiveWindow.ScrollRow = 108
  141. ActiveWindow.ScrollRow = 102
  142. ActiveWindow.ScrollRow = 100
  143. ActiveWindow.ScrollRow = 93
  144. ActiveWindow.ScrollRow = 88
  145. ActiveWindow.ScrollRow = 77
  146. ActiveWindow.ScrollRow = 69
  147. ActiveWindow.ScrollRow = 67
  148. ActiveWindow.ScrollRow = 62
  149. ActiveWindow.ScrollRow = 61
  150. ActiveWindow.ScrollRow = 56
  151. ActiveWindow.ScrollRow = 54
  152. ActiveWindow.ScrollRow = 49
  153. ActiveWindow.ScrollRow = 46
  154. ActiveWindow.ScrollRow = 43
  155. ActiveWindow.ScrollRow = 38
  156. ActiveWindow.ScrollRow = 28
  157. ActiveWindow.ScrollRow = 25
  158. ActiveWindow.ScrollRow = 17
  159. ActiveWindow.ScrollRow = 5
  160. Range("A6:F267,S6:T267").Select
  161. Range("S6").Activate
  162. Selection.Copy
  163. Sheets("Liste des Obso").Select
  164. Cells(Range("K1"), 1).Select
  165. ActiveSheet.Paste
  166. ActiveWindow.SmallScroll Down:=48
  167. Range("A63:G63").Select
  168. Application.CutCopyMode = False
  169. Selection.Borders(xlDiagonalDown).LineStyle = xlNone
  170. Selection.Borders(xlDiagonalUp).LineStyle = xlNone
  171. With Selection.Borders(xlEdgeLeft)
  172. .LineStyle = xlContinuous
  173. .ColorIndex = 0
  174. .TintAndShade = 0
  175. .Weight = xlThin
  176. End With
  177. With Selection.Borders(xlEdgeTop)
  178. .LineStyle = xlContinuous
  179. .ColorIndex = 0
  180. .TintAndShade = 0
  181. .Weight = xlThin
  182. End With
  183. With Selection.Borders(xlEdgeBottom)
  184. .LineStyle = xlContinuous
  185. .ColorIndex = 0
  186. .TintAndShade = 0
  187. .Weight = xlThin
  188. End With
  189. With Selection.Borders(xlEdgeRight)
  190. .LineStyle = xlContinuous
  191. .ColorIndex = 0
  192. .TintAndShade = 0
  193. .Weight = xlThin
  194. End With
  195. Selection.Borders(xlInsideVertical).LineStyle = xlNone
  196. Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
  197. With Selection.Interior
  198. .Pattern = xlSolid
  199. .PatternColorIndex = xlAutomatic
  200. .ThemeColor = xlThemeColorAccent5
  201. .TintAndShade = 0.799981688894314
  202. .PatternTintAndShade = 0
  203. End With
  204. Sheets("Procedure").Select
  205. ActiveSheet.Range("$A$1:$X$293").AutoFilter Field:=20
  206. Sheets("Instruction").Select
  207. ActiveWindow.ScrollColumn = 3
  208. ActiveWindow.ScrollColumn = 4
  209. ActiveWindow.ScrollColumn = 6
  210. ActiveWindow.ScrollColumn = 7
  211. ActiveWindow.ScrollColumn = 8
  212. ActiveWindow.ScrollColumn = 9
  213. ActiveWindow.ScrollColumn = 10
  214. ActiveWindow.ScrollColumn = 11
  215. ActiveWindow.ScrollColumn = 12
  216. ActiveWindow.ScrollColumn = 13
  217. Columns("S:U").Select
  218. Selection.EntireColumn.Hidden = False
  219. ActiveSheet.Range("$A$1:$Y$224").AutoFilter Field:=20, Criteria1:="<>"
  220. ActiveWindow.SmallScroll Down:=-24
  221. Range("S7:T168").Select
  222. ActiveWindow.ScrollColumn = 12
  223. ActiveWindow.ScrollColumn = 11
  224. ActiveWindow.ScrollColumn = 10
  225. ActiveWindow.ScrollColumn = 9
  226. ActiveWindow.ScrollColumn = 8
  227. ActiveWindow.ScrollColumn = 7
  228. ActiveWindow.ScrollColumn = 6
  229. ActiveWindow.ScrollColumn = 5
  230. ActiveWindow.ScrollColumn = 3
  231. ActiveWindow.ScrollColumn = 2
  232. ActiveWindow.SmallScroll Down:=-72
  233. Range("S7:T168,A7:F168").Select
  234. Range("F7").Activate
  235. Selection.Copy
  236. Sheets("Liste des Obso").Select
  237. Cells(Range("K1") + 1, 1).Select
  238. ActiveSheet.Paste
  239. Sheets("Instruction").Select
  240. ActiveWindow.SmallScroll ToRight:=9
  241. ActiveSheet.Range("$A$1:$Y$224").AutoFilter Field:=20
  242. Sheets("Liste des Obso").Select
  243. ActiveWindow.SmallScroll Down:=42
  244. Range("A100:G100").Select
  245. Application.CutCopyMode = False
  246. Selection.Borders(xlDiagonalDown).LineStyle = xlNone
  247. Selection.Borders(xlDiagonalUp).LineStyle = xlNone
  248. With Selection.Borders(xlEdgeLeft)
  249. .LineStyle = xlContinuous
  250. .ColorIndex = 0
  251. .TintAndShade = 0
  252. .Weight = xlThin
  253. End With
  254. With Selection.Borders(xlEdgeTop)
  255. .LineStyle = xlContinuous
  256. .ColorIndex = 0
  257. .TintAndShade = 0
  258. .Weight = xlThin
  259. End With
  260. With Selection.Borders(xlEdgeBottom)
  261. .LineStyle = xlContinuous
  262. .ColorIndex = 0
  263. .TintAndShade = 0
  264. .Weight = xlThin
  265. End With
  266. With Selection.Borders(xlEdgeRight)
  267. .LineStyle = xlContinuous
  268. .ColorIndex = 0
  269. .TintAndShade = 0
  270. .Weight = xlThin
  271. End With
  272. Selection.Borders(xlInsideVertical).LineStyle = xlNone
  273. Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
  274. With Selection.Interior
  275. .Pattern = xlSolid
  276. .PatternColorIndex = xlAutomatic
  277. .ThemeColor = xlThemeColorAccent5
  278. .TintAndShade = 0.799981688894314
  279. .PatternTintAndShade = 0
  280. End With
  281. Sheets("Liste").Select
  282. ActiveWindow.ScrollColumn = 5
  283. ActiveWindow.ScrollColumn = 6
  284. ActiveWindow.ScrollColumn = 7
  285. ActiveWindow.ScrollColumn = 8
  286. ActiveWindow.ScrollColumn = 9
  287. ActiveWindow.ScrollColumn = 10
  288. ActiveWindow.ScrollColumn = 11
  289. ActiveWindow.ScrollColumn = 12
  290. ActiveWindow.ScrollColumn = 13
  291. ActiveWindow.ScrollColumn = 14
  292. ActiveWindow.ScrollColumn = 15
  293. ActiveWindow.ScrollColumn = 16
  294. ActiveWindow.ScrollColumn = 17
  295. ActiveWindow.ScrollColumn = 16
  296. Columns("R:T").Select
  297. Selection.EntireColumn.Hidden = False
  298. ActiveSheet.Range("$A$1:$V$64").AutoFilter Field:=19, Criteria1:="<>"
  299. ActiveWindow.SmallScroll Down:=-27
  300. Range("R7:S49").Select
  301. ActiveWindow.ScrollColumn = 15
  302. ActiveWindow.ScrollColumn = 14
  303. ActiveWindow.ScrollColumn = 13
  304. ActiveWindow.ScrollColumn = 12
  305. ActiveWindow.ScrollColumn = 11
  306. ActiveWindow.ScrollColumn = 10
  307. ActiveWindow.ScrollColumn = 9
  308. ActiveWindow.ScrollColumn = 7
  309. ActiveWindow.ScrollColumn = 6
  310. ActiveWindow.ScrollColumn = 5
  311. ActiveWindow.ScrollColumn = 4
  312. Range("R7:S49,A7:E49").Select
  313. Range("E7").Activate
  314. Selection.Copy
  315. Sheets("Liste des Obso").Select
  316. Cells(Range("K1") + 2, 1).Select
  317. ActiveSheet.Paste
  318. Sheets("Liste").Select
  319. ActiveWindow.ScrollColumn = 5
  320. ActiveWindow.ScrollColumn = 6
  321. ActiveWindow.ScrollColumn = 7
  322. ActiveWindow.ScrollColumn = 8
  323. ActiveWindow.ScrollColumn = 9
  324. ActiveWindow.ScrollColumn = 10
  325. ActiveWindow.ScrollColumn = 11
  326. ActiveWindow.ScrollColumn = 12
  327. ActiveWindow.ScrollColumn = 13
  328. ActiveWindow.ScrollColumn = 14
  329. ActiveWindow.ScrollColumn = 15
  330. ActiveSheet.Range("$A$1:$V$64").AutoFilter Field:=19
  331. Sheets("Liste des Obso").Select
  332. ActiveWindow.ScrollRow = 94
  333. ActiveWindow.ScrollRow = 92
  334. ActiveWindow.ScrollRow = 90
  335. ActiveWindow.ScrollRow = 87
  336. ActiveWindow.ScrollRow = 85
  337. ActiveWindow.ScrollRow = 81
  338. ActiveWindow.ScrollRow = 79
  339. ActiveWindow.ScrollRow = 76
  340. ActiveWindow.ScrollRow = 73
  341. ActiveWindow.ScrollRow = 70
  342. ActiveWindow.ScrollRow = 68
  343. ActiveWindow.ScrollRow = 65
  344. ActiveWindow.ScrollRow = 62
  345. ActiveWindow.ScrollRow = 60
  346. ActiveWindow.ScrollRow = 57
  347. ActiveWindow.ScrollRow = 55
  348. ActiveWindow.ScrollRow = 53
  349. ActiveWindow.ScrollRow = 51
  350. ActiveWindow.ScrollRow = 49
  351. ActiveWindow.ScrollRow = 48
  352. ActiveWindow.ScrollRow = 45
  353. ActiveWindow.ScrollRow = 44
  354. ActiveWindow.ScrollRow = 42
  355. ActiveWindow.ScrollRow = 41
  356. ActiveWindow.ScrollRow = 39
  357. ActiveWindow.ScrollRow = 38
  358. ActiveWindow.ScrollRow = 36
  359. ActiveWindow.ScrollRow = 35
  360. ActiveWindow.ScrollRow = 34
  361. ActiveWindow.ScrollRow = 33
  362. ActiveWindow.ScrollRow = 32
  363. ActiveWindow.ScrollRow = 31
  364. ActiveWindow.ScrollRow = 30
  365. ActiveWindow.ScrollRow = 28
  366. ActiveWindow.ScrollRow = 27
  367. ActiveWindow.ScrollRow = 26
  368. ActiveWindow.ScrollRow = 25
  369. ActiveWindow.ScrollRow = 23
  370. ActiveWindow.ScrollRow = 22
  371. ActiveWindow.ScrollRow = 21
  372. ActiveWindow.ScrollRow = 20
  373. ActiveWindow.ScrollRow = 19
  374. ActiveWindow.ScrollRow = 18
  375. ActiveWindow.ScrollRow = 17
  376. ActiveWindow.ScrollRow = 16
  377. ActiveWindow.ScrollRow = 15
  378. ActiveWindow.ScrollRow = 14
  379. ActiveWindow.ScrollRow = 13
  380. ActiveWindow.ScrollRow = 12
  381. ActiveWindow.ScrollRow = 11
  382. ActiveWindow.ScrollRow = 10
  383. ActiveWindow.ScrollRow = 9
  384. ActiveWindow.ScrollRow = 8
  385. ActiveWindow.ScrollRow = 7
  386. ActiveWindow.ScrollRow = 6
  387. ActiveWindow.ScrollRow = 5
  388. Columns("A:A").Select
  389. Application.CutCopyMode = False
  390. Selection.Hyperlinks.Delete
  391. Range("A2").Select
  392. End Sub

Voici le programme mais je pense qu'il doit y avoir une solution beaucoup plus simple que celle là.
En fait j'ai enregistré une suite de réalisation manuelle dans les différentes feuilles.
J'ai essayé de faire avec la fonction filtre élaboré mais je ne dois pas faire comme il faut car il me dit qua la plage n'est pas valide....

vous verrez aussi que j'ai essayé de mettre une ligne de séparation entre chaque type de documents mais ça ne marche pas parfaitement non plus....

Merci beaucoup pour votre aide.

virginie
2 Février 2012 13:39:23

Salut,

Rhoooolala !

Ca se voit que tu t'es laissée guider par l'enregistreur de macro.
C'est un très bon début. Mais il manque le reste : le nettoyage du code.
Par exemple, les scrolls sont inutiles.
Or sur 392 lignes, on en trouve 214 ! :ouch: 

Par principe, on s'interdit d'utiliser le presse-papier comme mémoire temporaire.
C'est une zone partagée entre toutes les applications du système. Imagine que tous les programmes en fassent autant.
Bonjour la pagaille. On va voir comment faire autrement.

Tu jongles entre plusieurs feuilles, et tu comptes sur le système pour que la feuille, la cellule que tu sélectionnes restent actives.
C'est faire fort confiance à Windows et Excel. Au moindre "popeupètvousur", ta macro est plantée.

Par ailleurs, tu sélectionnes tel objet puis tu agis sur la sélection. Ben et si tu agissais directement sur l'objet ?
Exemple :
  1. ' // Pas terrible
  2. Rows("5:500").Select
  3. Selection.Delete Shift:=xlUp
  4.  
  5. ' // Plus simple, plus logique, plus petit, plus... mieux
  6. Rows("5:500").Delete

(J'ai aussi viré le Shift inutile puisque très intelligemment, tu as utilisé Rows())

Ensuite, je voudrais bien savoir pourquoi tu fais des filters et des masquages de colonnes au fur et à mesure.

Bon, je te laisse nous proposer un code un peu nettoyé.
Ensuite le programme c'est : te montrer comment ne pas passer par le presse-papier en utilisant mieux la méthode Copy() et comment désigner tes objets sans passer par des sélections.
m
0
l
3 Février 2012 13:05:37

zeb a dit :
Salut,

Rhoooolala !

Ca se voit que tu t'es laissée guider par l'enregistreur de macro.
C'est un très bon début. Mais il manque le reste : le nettoyage du code.
Par exemple, les scrolls sont inutiles.
Or sur 392 lignes, on en trouve 214 ! :ouch: 

Par principe, on s'interdit d'utiliser le presse-papier comme mémoire temporaire.
C'est une zone partagée entre toutes les applications du système. Imagine que tous les programmes en faisaient autant.
Bonjour la pagaille. On va voir comment faire autrement.

Tu jongles entre plusieurs feuilles, et tu comptes sur le système pour que la feuille, la cellule que tu sélectionnes restent actives.
C'est faire fort confiance à Windows et Excel. Au moindre "popeupètvousur", ta macro est plantée.

Par ailleurs, tu sélectionnes tel objet puis tu agis sur la sélection. Ben et si tu agissais directement sur l'objet ?
Exemple :
  1. // Pas terrible
  2. Rows("5:500").Select
  3. Selection.Delete Shift:=xlUp
  4.  
  5. // Plus simple, plus logique, plus petit, plus... mieux
  6. Rows("5:500").Delete

(J'ai aussi viré le Shift inutile puisque très intelligemment, tu as utilisé Rows())

Ensuite, je voudrais bien savoir pourquoi tu fais des filters et des masquages de colonnes au fur et à mesure.

Bon, je te laisse nous proposer un code un peu nettoyé.
Ensuite le programme c'est : te montrer comment ne pas passer par le presse-papier en utilisant mieux la méthode Copy() et comment désigner tes objets sans passer par des sélections.



Merci zeb,
Je me mets au travail et je reviens te montrer le résultat.

Oui, je travaille avec l'enregistreur de macro car j'ai eu une formation où l'on m'a beaucoup expliqué avec ce système. Je souhaitais une formation sur le language afin de mieux s'avoir l'appréhender et l'utiliser avant mais trop cher....
merci pour l'info du presse-papier, je ne savais pas.
Mais je vois que je suis pas si nulle que je le pensais, ça fait plaisir à lire et ça donne confiance.

Pour la question des filtres, c'est que dans cette colonne, je ne veux extraire que les données des lignes où il y a écrit "OBSO" ou "FUTUR OBSO" donc les cases de la colonne "obsolète" ne sont pas vide. Mais dans ces lignes, je ne veux à nouveau que extraire certaines colonnes, pas la ligne entière.

Je vais déjà faire ce que tu me dis et je te montre ce que ça donne début de semaine prochaine.
m
0
l
Contenus similaires
3 Février 2012 13:43:54

bon, comme ça me titille d'avancer sur ce sujet, j'ai essayé de "nettoyer" mon code :

  1. Sub Actualiser()
  2. '
  3. ' Macro1 Macro
  4. '
  5.  
  6. '
  7. Rows("5:500").Delete
  8. Range("A5").Select
  9. Sheets("Ancien Systeme").Select
  10. ActiveSheet.Range("$B$1:$W$10").AutoFilter Field:=18, Criteria1:="<>"
  11. Range("R3:S10").Select
  12. Range("R3:S10,B3:E10").Select
  13. Range("E3").Activate
  14. Selection.Copy
  15. Sheets("Liste des Obso").Select
  16. Range("B5").Select
  17. ActiveSheet.Paste
  18. Sheets("Ancien Systeme").Select
  19. ActiveSheet.Range("$B$1:$W$10").AutoFilter Field:=18
  20. Sheets("Procedure").Select
  21. ActiveSheet.Range("$A$1:$X$293").AutoFilter Field:=20, Criteria1:="<>"
  22. Range("S6:T267").Select
  23. Range("A6:F267").Select
  24. Range("F6").Activate
  25. Range("A6:F267,S6:T267").Select
  26. Range("S6").Activate
  27. Selection.Copy
  28. Sheets("Liste des Obso").Select
  29. Cells(Range("K1"), 1).Select
  30. ActiveSheet.Paste
  31. Sheets("Procedure").Select
  32. ActiveSheet.Range("$A$1:$X$293").AutoFilter Field:=20
  33. Sheets("Instruction").Select
  34. Columns("S:U").Select
  35. Selection.EntireColumn.Hidden = False
  36. ActiveSheet.Range("$A$1:$Y$224").AutoFilter Field:=20, Criteria1:="<>"
  37. Range("S7:T168").Select
  38. Range("S7:T168,A7:F168").Select
  39. Range("F7").Activate
  40. Selection.Copy
  41. Sheets("Liste des Obso").Select
  42. Cells(Range("K1") + 1, 1).Select
  43. ActiveSheet.Paste
  44. Sheets("Instruction").Select
  45. ActiveSheet.Range("$A$1:$Y$224").AutoFilter Field:=20
  46. Sheets("Liste des Obso").Select
  47. Sheets("Liste").Select
  48. Columns("R:T").Select
  49. Selection.EntireColumn.Hidden = False
  50. ActiveSheet.Range("$A$1:$V$64").AutoFilter Field:=19, Criteria1:="<>"
  51. Range("R7:S49").Select
  52. Range("R7:S49,A7:E49").Select
  53. Range("E7").Activate
  54. Selection.Copy
  55. Sheets("Liste des Obso").Select
  56. Cells(Range("K1") + 2, 1).Select
  57. ActiveSheet.Paste
  58. Sheets("Liste").Select
  59. ActiveSheet.Range("$A$1:$V$64").AutoFilter Field:=19
  60. Sheets("Liste des Obso").Select
  61. Columns("A:A").Select
  62. Application.CutCopyMode = False
  63. Selection.Hyperlinks.Delete
  64. Range("A2").Select
  65.  
  66. End Sub


J'ai aussi enlevé l'histoire de mettre une ligne entre chaque extraction d'une feuille mais je n'ai pas dû enlever tout ce qu'il faut car il me mets encore une ligne mais vide cette fois entre chaque.
Je continue de regarder pour améliorer encore tout ça ;) 
m
0
l
3 Février 2012 15:50:20

Ah.... :) 
Tu as cet état d'esprit que j'aime tant et qui me fait continuer sur ce forum.

Juste pour faire joli, ajoute le langage à ta balise : [code=VB][/code].
m
0
l
3 Février 2012 16:35:17

Prenons le premier block.
  1. Rows("5:500").Delete ' // De quelle feuille ?
  2. Range("A5").Select ' // Pour quoi faire ?
  3. Sheets("Ancien Systeme").Select ' // zeb à dit : pas de select
  4. ActiveSheet.Range("$B$1:$W$10").AutoFilter Field:=18, Criteria1:="<>" ' // A revoir
  5. Range("R3:S10").Select ' // Pour quoi faire ?
  6. Range("R3:S10,B3:E10").Select ' // Cette zone n'est pas fixe !!!!!!!
  7. Range("E3").Activate ' // Pour quoi faire ?
  8. Selection.Copy ' // zeb à dit : mieux utiliser la fonction Copy
  9. Sheets("Liste des Obso").Select ' // zeb à dit : pas de select
  10. Range("B5").Select ' // zeb à dit : pas de select
  11. ActiveSheet.Paste ' // zeb à dit : pas de presse-papier


Comme on a plusieurs feuilles, on va explicitement les nommer.
  1. ' // Préparation
  2. Dim f_as As Worksheet ' // Feuille Ancient Système
  3. Dim f_lo As Worksheet ' // Feuille liste des obso
  4. Dim f_my As Worksheet ' // Feuille mystère ???
  5.  
  6. Set f_as = Worksheets("Ancien Systeme")
  7. Set f_lo = Worksheets("Liste des Obso")
  8. Set f_my = ActiveSheet
  9.  
  10. ' // Début
  11. f_my.Rows("5:500").Delete


Bon, dans ton code, le filtre te permet de faire "disparaître" des lignes.
Mais la zone R3:S10,B3:E10 est calculé par Excel en fontion du filtre quand tu joues avec ta souris. Pas par macro !!!!
Il va falloir faire nous même cette manip'.
(D'où l'intérêt de ne pas faire de filtre par macro, d'où ma surprise d'en trouver dans ton code)

Q1) Quelle est la zone susceptible de contenir tes données à copier ?
Q2) Quel critère pour choisir une ligne ?
Q3) Quelles colonnes copier ?

Bon, admettons que la réponse à Q1 soit A1:W500
Pour Q2, c'est "OBSO" ou "FUTUR OBSO", disons dans la colonne R. (Mais ce pourrait être "une valeur dans la colonne J" par exemple.)
Pour l'exemple, on peut dire A, C, E, G :spamafote: 

Or donc, on va parcourir toute la zone, ligne par ligne.
Pour chaque ligne on va vérifier si elle nous intéresse.
Puis on va la copier dans la liste des obso'.

Là en core un peu de préparation : où copier ?
  1. Dim cible As Range
  2.  
  3. Set cible = f_lo.Range("A1") '// Peut être voudrais-tu commencer plus bas que la première ligne ?

  1. Dim ligne as Range ' // 1 ligne
  2. Dim acopier as Range ' // Les cellules à copier
  3.  
  4. For Each ligne In f_as.Rows("1:500")
  5. ' // La 18ème cellule d'une ligne est dans la colonne R
  6. If ligne.Cells(18).Value like "*OBSO" Then
  7. ' // A C E G
  8. Set acopier = Union(ligne.Cells(1), ligne.Cells(3), ligne.Cells(5), ligne.Cells(7))
  9. acopier.Copy Destination:=cible
  10. Set cible = cible.Offset(1)
  11. End If
  12. Next


Et voilà !
Étudie bien mon exemple. Et généralise pour ton cas.
Regarde bien cette histoire de "cible".
J'attends tes commentaires, tes questions et ton code revu et corrigé.

Pour le prix de 0€, tu vas l'avoir ta formation ;) 
(Mais t'as maintenant des devoirs à faire :lol:  )
m
0
l
3 Février 2012 17:20:00

ok pour le code, je vais faire mieux avec mon prochain devoir à corriger! :D 

là maintenant le plus dur sera d'attendre lundi de retourner au boulot pour me plonger dans tout ce que tu viens de m'apprendre!!!!!! :pt1cable: 
le week end va être long du coup!!!:lol: 

et merci, j'apprécie vraiment le coup de main pour comprendre ce que je suis en train d'essayer d'écrire! ;) 
m
0
l
6 Février 2012 17:15:15

Bonjour Zeb,

voilà, je me retrouve bloquée par un message erreur mais je ne comprends pas ce qu'il veut exactement :

  1. Sub Actualiser()
  2. '
  3. ' // Préparation
  4.  
  5. Dim f_pr As Worksheet ' // Feuille Procedure
  6. Dim f_in As Worksheet ' // Feuille Instruction
  7. Dim f_fr As Worksheet ' // Feuille Formulaire
  8. Dim f_li As Worksheet ' // Feuille Liste
  9. Dim f_lo As Worksheet ' // Feuille liste des obso
  10.  
  11. Set f_pr = Worksheets("Procedure")
  12. Set f_in = Worksheets("Instruction")
  13. Set f_fr = Worksheets("Formulaire")
  14. Set f_li = Worksheets("Liste")
  15. Set f_lo = ActiveSheet
  16.  
  17. Dim cible As Range
  18. Dim cible = f_lo.Range ("A5") ' j'ai ce message à ce niveau là :"Erreur de compilation Attendu : fin d'instruction"
  19. Dim ligne As Range
  20. Dim acopier As Range
  21.  
  22.  
  23. ' // Début
  24.  
  25. f_lo.Rows("5:500").Delete
  26. For Each ligne In f_pr.Rows("1:500")
  27. If ligne.Cells(19).Value Like "*OBSO" Then
  28. Set acopier = Union(ligne.Cells(1), ligne.Cells(2), ligne.Cells(3), ligne.Cells(4), ligne.Cells(5), ligne.Cells(18))
  29. acopier.Copy Destination:=cible
  30. Set cible = cible.Offset(1)
  31. End If
  32. Next
  33.  
  34. End Sub


Je voulais essayer si ce début marchait mais avec ce message erreur, je n'arrive pas à aller plus loin....

Tu verras que pour le moment, j'ai laissé tomber la feuille ancien système qui de toute façon ne comporte que 5 lignes et je peux facilement les inclure en fin de tableau quand la macro marchera pour les autres feuiles.
Je vais essayer de comprendre déjà ça et je la compliquerais par la suite!
en espérant ne pas trop te décevoir....
m
0
l
7 Février 2012 08:42:53

Oh, c'est dommage d'avoir été bloquée par si peu. :( 
Remplace *évidemment* Dim par Set à la ligne 18 et continue.

Tu aurais pu le voir quand même :o 
Spoiler
Tu remarqueras que j'ai lâchement édité mon message pour ne pas qu'on voit que l'erreur venait de moi
(ne pas cliquer sur spoiler)

Pour le reste, il me semble que tu as bien compris.

Où enregistres-tu cette fonction ? Dans le code d'une feuille, du classeur, d'un module ?

Dans VBA/Excel, regarde un peu l'aide sur l'Option Explicit et si ce n'est pas encore fait, utilise-la.


A te lire.
m
0
l
7 Février 2012 09:01:23

zeb a dit :
Oh, c'est dommage d'avoir été bloquée par si peu. :( 
Remplace *évidemment* Dim par Set à la ligne 18 et continue.

Tu aurais pu le voir quand même :o 
Spoiler
Tu remarqueras que j'ai lâchement édité mon message pour ne pas qu'on voit que l'erreur venait de moi
(ne pas cliquer sur spoiler)

Pour le reste, il me semble que tu as bien compris.

Où enregistres-tu cette fonction ? Dans le code d'une feuille, du classeur, d'un module ?

Dans VBA/Excel, regarde un peu l'aide sur l'Option Explicit et si ce n'est pas encore fait, utilise-la.


A te lire.


:lol:  promis, je n'ai pas lu ton spoiler!! :lol: 

J'enregistre cette fonction dans un module et j'ai créé un bouton dans la feuille "liste des obso" auquel j'ai relié la macro. C'est bien ou il y a mieux à faire?

Je ne connaissais pas l'option explicit, je m'en vais de ce pas voir ce que c'est et continuer le code! :) 
m
0
l
7 Février 2012 09:36:36

Ton code est associé à ta feuille "Liste des obso". Alors mets-le donc là !
Ou bien laisse-le là où il est, ce n'est pas plus mal :spamafote: 

Mais par contre, la ligne 15, ce n'est pas bon !
Par principe, Il ne faut pas faire confiance à ce qui est actif à un moment donné.
  1. Set f_lo = ActiveSheet

Je te laisse corriger ça.

Pour info, si tu avais mis ta fonction dans le code de la feuille, tu aurais pu utiliser le mot-clef me qui se rapporte à la feuille, et ainsi te dispenser de déclarer f_lo. C'est un point de détail. Mais puisque tu es là pour apprendre... ;) 
m
0
l
7 Février 2012 11:57:35

Bon, je dois faire un truc qui ne va pas....
j'ai mis le code dans la feuille et j'ai donc utilisé le mot clé Me.
J'ai donc supprimé le module existant.
Mais j'ai dû supprimer quelque chose qu'il ne fallait pas....:??: 

Voici mon code :

  1. Sub Actualiser()
  2. '
  3. ' // Préparation
  4.  
  5. Dim f_pr As Worksheet ' // Feuille Procedure
  6. Dim f_in As Worksheet ' // Feuille Instruction
  7. Dim f_fr As Worksheet ' // Feuille Formulaire
  8. Dim f_li As Worksheet ' // Feuille Liste
  9.  
  10. Set f_pr = Worksheets("Procedure")
  11. Set f_in = Worksheets("Instruction")
  12. Set f_fr = Worksheets("Formulaire")
  13. Set f_li = Worksheets("Liste")
  14.  
  15. Dim cible As Range
  16. Set cible = Me.Range("A5")
  17. Dim ligne As Range
  18. Dim acopier As Range
  19.  
  20.  
  21. ' // Début
  22.  
  23. Me.Rows("5:500").Delete
  24. For Each ligne In f_pr.Rows("1:500")
  25. If ligne.Cells(19).Value Like "*OBSO" Then
  26. Set acopier = Union(ligne.Cells(1), ligne.Cells(2), ligne.Cells(3), ligne.Cells(4), ligne.Cells(5), ligne.Cells(18))
  27. acopier.Copy Destination:=cible
  28. Set cible = cible.Offset(1)
  29. End If
  30. Next
  31. For Each ligne In f_in.Rows("1:500")
  32. If ligne.Cells(19).Value Like "*OBSO" Then
  33. Set acopier = Union(ligne.Cells(1), ligne.Cells(2), ligne.Cells(3), ligne.Cells(4), ligne.Cells(5), ligne.Cells(18))
  34. acopier.Copy Destination:=cible
  35. Set cible = cible.Offset(1)
  36. End If
  37. Next
  38. For Each ligne In f_fr.Rows("1:500")
  39. If ligne.Cells(19).Value Like "*OBSO" Then
  40. Set acopier = Union(ligne.Cells(1), ligne.Cells(2), ligne.Cells(3), ligne.Cells(4), ligne.Cells(5), ligne.Cells(18))
  41. acopier.Copy Destination:=cible
  42. Set cible = cible.Offset(1)
  43. End If
  44. Next
  45. For Each ligne In f_li.Rows("1:500")
  46. If ligne.Cells(19).Value Like "*OBSO" Then
  47. Set acopier = Union(ligne.Cells(1), ligne.Cells(2), ligne.Cells(3), ligne.Cells(4), ligne.Cells(5), ligne.Cells(18))
  48. acopier.Copy Destination:=cible
  49. Set cible = cible.Offset(1)
  50. End If
  51. Next
  52. End Sub
m
0
l
7 Février 2012 14:01:29

j'ai remis le code dans un module, histoire déjà de comprendre ce qui ne va pas.
ensuite j'essaierais de simplifier.
je suis en train de chercher ce qui cloche en même temps et j'apprend les définitions de certains termes pour comprendre à quoi ils servent car j'avoue que la fonction "Set cible = cible.Offset(1)" m'étais inconnue....

  1. Option Explicit
  2.  
  3. Sub Actualiser()
  4. '
  5. ' // Préparation
  6.  
  7.  
  8. Dim f_pr As Worksheet ' // Feuille Procedure
  9. Dim f_in As Worksheet ' // Feuille Instruction
  10. Dim f_fr As Worksheet ' // Feuille Formulaire
  11. Dim f_li As Worksheet ' // Feuille Liste
  12. Dim f_lo As Worksheet ' // Feuille Liste des Obso
  13.  
  14. Set f_pr = Worksheets("Procedure")
  15. Set f_in = Worksheets("Instruction")
  16. Set f_fr = Worksheets("Formulaire")
  17. Set f_li = Worksheets("Liste")
  18. Set f_lo = Worksheets("Liste des Obso")
  19.  
  20. Dim cible As Range
  21. Set cible = f_lo.Range("A5")
  22. Dim ligne As Range
  23. Dim acopier As Range
  24.  
  25.  
  26. ' // Début
  27.  
  28.  
  29. f_lo.Rows("5:500").Delete
  30. For Each ligne In f_pr.Rows("1:500")
  31. If ligne.Cells(19).Value Like "*OBSO" Then
  32. Set acopier = Union(ligne.Cells(1), ligne.Cells(2), ligne.Cells(3), ligne.Cells(4), ligne.Cells(5), ligne.Cells(18))
  33. acopier.Copy Destination:=cible
  34. Set cible = cible.Offset(1)
  35. End If
  36. Next
  37. For Each ligne In f_in.Rows("1:500")
  38. If ligne.Cells(19).Value Like "*OBSO" Then
  39. Set acopier = Union(ligne.Cells(1), ligne.Cells(2), ligne.Cells(3), ligne.Cells(4), ligne.Cells(5), ligne.Cells(18))
  40. acopier.Copy Destination:=cible
  41. Set cible = cible.Offset(1)
  42. End If
  43. Next
  44. For Each ligne In f_fr.Rows("1:500")
  45. If ligne.Cells(19).Value Like "*OBSO" Then
  46. Set acopier = Union(ligne.Cells(1), ligne.Cells(2), ligne.Cells(3), ligne.Cells(4), ligne.Cells(5), ligne.Cells(18))
  47. acopier.Copy Destination:=cible 'j'ai le message erreur d'exécution '1004' la méthode Copy de la classe Range a échoué
  48. Set cible = cible.Offset(1)
  49. End If
  50. Next
  51. For Each ligne In f_li.Rows("1:500")
  52. If ligne.Cells(19).Value Like "*OBSO" Then
  53. Set acopier = Union(ligne.Cells(1), ligne.Cells(2), ligne.Cells(3), ligne.Cells(4), ligne.Cells(5), ligne.Cells(18))
  54. acopier.Copy Destination:=cible
  55. Set cible = cible.Offset(1)
  56. End If
  57. Next
  58. End Sub
m
0
l
8 Février 2012 15:25:13

Oh malheur ! :( 
Ligne 21, on définit Cible du côté de la ligne 5.
Ligne 29, on atomise toutes les lignes, de la première à la cinq-centième, en explosant donc Cible.

Une solution toute simple : définir Cible après le Delete !
m
0
l
10 Février 2012 10:57:55

salut zeb,

ça marche, mais à moitié.
Il me place bien les données de la feuille formulaire et Liste mais pas les données les données des deux premières feuilles.

  1. Option Explicit
  2.  
  3. Sub Actualiser()
  4. '
  5. ' // Préparation
  6.  
  7.  
  8. Dim f_pr As Worksheet ' // Feuille Procedure
  9. Dim f_in As Worksheet ' // Feuille Instruction
  10. Dim f_fr As Worksheet ' // Feuille Formulaire
  11. Dim f_li As Worksheet ' // Feuille Liste
  12. Dim f_lo As Worksheet ' // Feuille Liste des Obso
  13.  
  14. Set f_pr = Worksheets("Procedure")
  15. Set f_in = Worksheets("Instruction")
  16. Set f_fr = Worksheets("Formulaire")
  17. Set f_li = Worksheets("Liste")
  18. Set f_lo = Worksheets("Liste des Obso")
  19.  
  20. 'nettoyage de la feille
  21.  
  22. f_lo.Rows("5:500").Delete
  23.  
  24. ' définition de la cible
  25.  
  26. Dim cible As Range
  27. Set cible = f_lo.Range("A5")
  28. Dim ligne As Range
  29. Dim acopier As Range
  30.  
  31. For Each ligne In f_pr.Rows("1:500")
  32. If ligne.Cells(19).Value Like "*OBSO" Then
  33. Set acopier = Union(ligne.Cells(1), ligne.Cells(2), ligne.Cells(3), ligne.Cells(4), ligne.Cells(5), ligne.Cells(18), ligne.Cells(19))
  34. acopier.Copy Destination:=cible
  35. Set cible = cible.Offset(1)
  36. End If
  37. Next
  38. For Each ligne In f_in.Rows("1:500")
  39. If ligne.Cells(19).Value Like "*OBSO" Then
  40. Set acopier = Union(ligne.Cells(1), ligne.Cells(2), ligne.Cells(3), ligne.Cells(4), ligne.Cells(5), ligne.Cells(18), ligne.Cells(19))
  41. acopier.Copy Destination:=cible
  42. Set cible = cible.Offset(1)
  43. End If
  44. Next
  45. For Each ligne In f_fr.Rows("1:500")
  46. If ligne.Cells(19).Value Like "*OBSO" Then
  47. Set acopier = Union(ligne.Cells(1), ligne.Cells(2), ligne.Cells(3), ligne.Cells(4), ligne.Cells(5), ligne.Cells(18), ligne.Cells(19))
  48. acopier.Copy Destination:=cible
  49. Set cible = cible.Offset(1)
  50. End If
  51. Next
  52. For Each ligne In f_li.Rows("1:500")
  53. If ligne.Cells(19).Value Like "*OBSO" Then
  54. Set acopier = Union(ligne.Cells(1), ligne.Cells(2), ligne.Cells(3), ligne.Cells(4), ligne.Cells(5), ligne.Cells(18), ligne.Cells(19))
  55. acopier.Copy Destination:=cible
  56. Set cible = cible.Offset(1)
  57. End If
  58. Next
  59. End Sub
m
0
l
10 Février 2012 12:03:51

Salut,

>> ça marche,
Ah... :) 

>> mais à moitié.
Ohhh :( 

--------

Respecte bien le principe d'indentation. Par exemple, tes lignes 33, 34, 35 doivent être tabulées une fois de plus.
Oui, je sais, c'est du pinaillage. Mais n'es-tu pas là pour apprendre :à

--------

Mets l'instruction Stop (va voir dans l'aide à quoi elle sert. Je me dis que tu peux quand même deviner ;)  ) entre les lignes 37 et 38.
Relance. Et arrête ta macro. Ceci pour se concentrer sur la première partie du code.

Vérifie que tu as bien des lignes qui contiennent "OBSO" dans la cellule 19, sans espace après, etc.
Fais-toi un classeur de test pour en être sûr. Ajoute une ligne 1 que tu rempliras à la main et apprends à déboguer toute seule (*) : http://www.presence-pc.com/forum/ppc/Programmation/tuto...

______
(*) Je reste là, hein ;) 
m
0
l
13 Février 2012 11:52:18

hello!!

:)  voilà, tout le programme marche!
je suis super contente d'avoir réussi, merci beaucoup pour ton aide si précieuse!!! ;) 

j'ai juste une dernière question, sur un autre fichier, j'ai créé une autre macro qui marche, grâce à ce que j'ai appris ici!
mais j'ai voulu y incure un bouton "QUITTER" pour femer le fichier ouvert. Sauf que biensûr, j'ai mis "application.quit" donc il me ferme tous les fichiers excel ouvert ....
Il faut que je définisse mon fichier et ensuite que je lui dise de le fermer, c'est ça?
m
0
l
13 Février 2012 15:58:17

finalement, j'ai autre chose à te demander.....:ange: 

voilà, j'ai utilisé le code dans un autre fichier semblable mais on m'a demandé de pouvoir trier les documents par service émetteur et par condition. J'ai immédiatement pensé à inclure deux autres userform avec combobox pour utiliser une liste de choix et aller copier les réponses dans la feuille et utiliser ces réponses comme données d'entrée de mon tri en colonne L et M.
Mon soucis est le bout de code " If ligne.Cells(20).Value Like "*OBSO" Then" car j'aimerais qu'il aille chercher la valeur a un endroit donné et non pas la définir directement dans le code et lui ajouter le choix du service émetteur.
L'endroit donné étant défini grâce à mes userform 10 et 11 dans le code.

  1. Private Sub CommandButton8_Click()
  2. '
  3. ' // Préparation
  4.  
  5.  
  6. Dim f_pr As Worksheet ' // Feuille Procedure
  7. Dim f_in As Worksheet ' // Feuille Instruction
  8. Dim f_fr As Worksheet ' // Feuille Formulaire
  9. Dim f_li As Worksheet ' // Feuille Liste
  10. Dim f_lo As Worksheet ' // Feuille Extraction Obso
  11.  
  12. Set f_pr = Worksheets("Procedure")
  13. Set f_in = Worksheets("Instruction")
  14. Set f_fr = Worksheets("Formulaire")
  15. Set f_li = Worksheets("Liste")
  16. Set f_lo = Worksheets("Extraction Obso")
  17.  
  18. 'nettoyage de la feille
  19.  
  20. f_lo.Rows("2:500").Delete
  21.  
  22. 'définition des valeurs service et condition
  23. UserForm10.Show '// mets la valeurs de la condition en L2 de la Feuille Extraction Obso
  24. UserForm11.Show '// mets la valeurs du service émetteur en M2 de la Feuille Extraction Obso
  25.  
  26. ' définition de la cible
  27.  
  28. Dim cible As Range
  29. Set cible = f_lo.Range("A2")
  30. Dim ligne As Range
  31. Dim acopier As Range
  32.  
  33. For Each ligne In f_pr.Rows("1:500")
  34. If ligne.Cells(20).Value Like "*OBSO" Then
  35. Set acopier = Union(ligne.Cells(1), ligne.Cells(2), ligne.Cells(3), ligne.Cells(5), ligne.Cells(6), ligne.Cells(19), ligne.Cells(20))
  36. acopier.Copy Destination:=cible
  37. Set cible = cible.Offset(1)
  38. End If
  39. Next
  40.  
  41. For Each ligne In f_in.Rows("1:500")
  42. If ligne.Cells(20).Value Like "*OBSO" Then
  43. Set acopier = Union(ligne.Cells(1), ligne.Cells(2), ligne.Cells(3), ligne.Cells(5), ligne.Cells(6), ligne.Cells(19), ligne.Cells(20))
  44. acopier.Copy Destination:=cible
  45. Set cible = cible.Offset(1)
  46. End If
  47. Next
  48. For Each ligne In f_fr.Rows("1:500")
  49. If ligne.Cells(19).Value Like "*OBSO" Then
  50. Set acopier = Union(ligne.Cells(1), ligne.Cells(2), ligne.Cells(3), ligne.Cells(4), ligne.Cells(5), ligne.Cells(18), ligne.Cells(19))
  51. acopier.Copy Destination:=cible
  52. Set cible = cible.Offset(1)
  53. End If
  54. Next
  55. For Each ligne In f_li.Rows("1:500")
  56. If ligne.Cells(19).Value Like "*OBSO" Then
  57. Set acopier = Union(ligne.Cells(1), ligne.Cells(2), ligne.Cells(3), ligne.Cells(4), ligne.Cells(5), ligne.Cells(18), ligne.Cells(19))
  58. acopier.Copy Destination:=cible
  59. Set cible = cible.Offset(1)
  60. End If
  61. Next
  62. Sheets("Extraction Obso").Select
  63. Range("A1").Select
  64. UserForm1.Hide
  65. End Sub
m
0
l
14 Février 2012 10:15:26

Salut,

Eh, moi aussi je suis content que ça marche :) 

Douillou spique angliche ?
Parce que quitter, ça se dit to quit et fermer, ça se dit to close.

Or toi, tu ne veux pas quitter l'application, tu veux fermer ton classeur. Alors tu prends ton classeur (tip: c'est un workbook) et tu le fermes.

-----------------------------

Bon, je suis informaticien et je n'aime vraiment pas faire deux fois la même chose. Alors quand je vois que nous faisons 4 fois la même choses... argggh ! X_x

Regarde ça :
  1. Dim feuille As Worksheet
  2. For Each feuille In Array(f_pr, f_in, f_fr, f_li)
  3. For Each ligne In feuille.Rows("1:500")
  4. If ligne.Cells(20).Value Like "*OBSO" Then
  5. Set acopier = Nothing
  6. For Each i In Array(1, 2, 3, 5, 6, 19, 20)
  7. Set acopier = IIf(acopier Is Nothing, ligne.Cells(i), Union(acopier, ligne.Cells(i)))
  8. Next
  9. acopier.Copy Destination:=cible
  10. Set cible = cible.Offset(1)
  11. End If
  12. Next
  13. Next


Bon, il y a une monstruosité dans ce code. C'est le Rows("1:500"). D'où sort ce 500 ?
(Si je lève le lièvre, c'est que j'ai des trucs à te montrer ;)  T'es toujours là pour apprendre ?)

-----------------------------

Bon, donc attention. Le code proposé avec l'opérateur Like est encore un truc de fainéantinformaticien pour ne pas trop en écrire. LIKE "*MOT" signifie : qui se termine par "MOT". Or maintenant, ce mot est à chercher dans une cellule, ce n'est pas pareil.

Il faudra écrire : Value = "MOT"
Où est MOT ?
Dans une cellule :
  1. Value = feuille.Range("Xn")

Dans une variable :
  1. Dim Xn As String
  2. Value = Xn


Qu'est-ce que le service émetteur ?
Une autre colonne ?
Bon :
  1. If ligne.Cells(20).Value = "MOT" And ligne.Cells(autre_colonne).Value = "service émetteur" Then ..
m
0
l
14 Février 2012 16:29:56

yes, i speak english very well ( :/  ) but sometimes my blonde highlights stand out....:D 
avec un close, ça va beaucoup mieux.....:ange: 

"Bon, il y a une monstruosité dans ce code. C'est le Rows("1:500"). D'où sort ce 500 ?
(Si je lève le lièvre, c'est que j'ai des trucs à te montrer T'es toujours là pour apprendre ?)"


OUI OUI, je suis toujours là pour apprendre! of course!!!!
le 500, c'est juste pour sélectionner un certains nombre de ligne..... et j'ai pris large pour être sûre de tout sélectionner....

Pour une question d'estétique du fichier, je démarre ma macro d'une feuille qui s'appelle Menu dans laquelle j'ai placé un bouton relié à cette macro.

Pour la condition et le service émetteur, je les place grâce à combobox dans les cellules L2 et M2 de la feuille "Extraction Obso" ou f_lo puisse que nous l'avons définie ainsi.
Donc, quand je clique sur mon bouton d'extraction (situé dans la feuille Menu), une première fenêtre me propose de choisir entre trois conditions : OBSO, FUTUR OBSO ou *OBSO (et place celle choisie dans la case L2 de la feuille f_lo puis une deuxième fenêtre me demande de choisir le service concerné : Achats, AQ, CQ, Info, Maintenance, Logistique.....etc (et place celui choisi dans la case M2 de la feuille f_lo)
Maintenant, il faut extraire de toutes les feuilles f_pr, f_in, f_fr, f_li les colonnes voulues des lignes qui remplissent ces deux conditions et les placer les unes à la suite des autres dans la feuille "Extraction Obso".

Le service émetteur se situe dans la colonne 6 et la condition dans la colonne 20 de chaque feuille.

Voilà, ça te donne plus d'infos sur ma façon d'exécuter la macro.




m
0
l
15 Février 2012 09:46:11

500 pour faire large. Mauvaise réponse !

D'abord la leçon : http://www.presence-pc.com/forum/ppc/Programmation/tuto...

Ensuite l'exercice. Remplace dans ton code le nombre 500 par le nombre exact de lignes.

Les questions (pertinentes) sont les bienvenues.

------------------------------

"*OBSO" est-ce une valeur ou bien est-ce pour dire que seules les dernières lettres sont significatives ?
Dans le premier cas, on mettra un signe égal dans la clause If, dans l'autre on laissera le Like.

------------------------------

Je ne vois pas ce qui te bloque pour que tu le fasses toi-même.
A la rigueur, propose un truc - même s'il ne marche pas, et on en discute.
m
0
l
15 Février 2012 21:33:11

ben c'est que mon nombre de lignes varie toujours, donc pour être sûre de prendre "tout le monde", j'ai mis 500....
merci pour le tutoriel, j'irais zieuter pour améliorer ma mauvaise réponse et essayer d'en proposer une meilleure!

pour le "*OBSO", non, c'est que dans une colonne, j'ai une condition en fonction des dates. Mes documents sont valides un certain temps donc pour pouvoir faire ressortir les documents devenu obsolète et les document arrivant a obsolescence dans les 3 prochains mois, j'ai mis une formule dans une colonne qui me donne de ce fait soit OBSO soit FUTUR OBSO. Et du coup, pour choisir les deux conditions, ben je mets "*OBSO" pour rechercher les lignes qui contiennent le mot OBSO.
Mais comme rien est simple, forcément, il faut pouvoir extraire soit OBSO, soit FUTUR OBSO, soit les deux!
et par service en plus, car chaque service veut pouvoir faire cette extraction pour son propre service et pas être pollué par les documents des autres services.

Pour répondre à ta question sur ce qui me bloque, pour l'instant, c'est le temps que je peux consacrer sans être déranger au bureau. Dans un bureau de trois avec du passage, c'est difficile de se concentrer et du coup, il y a des moments où tout se mélange et devient du chinois pour moi....:( 
Mais je ne désespère pas ;)  , je mets à profit les moments du midi et la fin d'après-midi quand je peux fermer la porte du bureau et ainsi m'isoler. Malheureusement, ça ne me laisse pas énormément de temps...
enfin, bref, je ne vais pas raconter ma vie, je ne suis pas ici pour ça.

J'ai essayé qlq chose ce midi mais j'ai un message erreur, je posterais mon code revu et réduit :)  j'espère demain ou vendredi pour voir ce que tu en penses.
Merci pour ta patience!
m
0
l
16 Février 2012 08:42:09

Ma patience ?! Elle est infinie. Ici c'est un forum, pas un tchat. Aucun problème de longueur de temps.
(T'as qu'à voir ma réaction quand un guguss met "URGENT !!!!!!!!!!!" dans le titre de son sujet :lol:  )

A te lire.
m
0
l
20 Février 2012 14:34:29

zeb a dit :
Ma patience ?! Elle est infinie. Ici c'est un forum, pas un tchat. Aucun problème de longueur de temps.
(T'as qu'à voir ma réaction quand un guguss met "URGENT !!!!!!!!!!!" dans le titre de son sujet :lol:  )

A te lire.



Bonjour Zeb,

dans un premier temps, j'ai essayé de simplifier mais je dois zapper qlq chose ou j'ai pas compris....:/
J'ai noté dans le code le message erreur :


  1. Private Sub CommandButton8_Click()
  2. '
  3. ' // Préparation
  4.  
  5.  
  6. Dim f_pr As Worksheet ' // Feuille Procedure
  7. Dim f_in As Worksheet ' // Feuille Instruction
  8. Dim f_fr As Worksheet ' // Feuille Formulaire
  9. Dim f_li As Worksheet ' // Feuille Liste
  10. Dim f_lo As Worksheet ' // Feuille Extraction Obso
  11.  
  12. Set f_pr = Worksheets("Procedure")
  13. Set f_in = Worksheets("Instruction")
  14. Set f_fr = Worksheets("Formulaire")
  15. Set f_li = Worksheets("Liste")
  16. Set f_lo = Worksheets("Extraction Obso")
  17.  
  18.  
  19. 'nettoyage de la feuille
  20.  
  21. f_lo.Rows("2:500").Delete
  22.  
  23. 'définition des valeurs service et condition
  24. UserForm10.Show '// mets la valeurs de la condition en L2 de la Feuille Extraction Obso
  25. UserForm11.Show '// mets la valeurs du service émetteur en M2 de la Feuille Extraction Obso
  26.  
  27. ' définition de la cible
  28.  
  29. Dim cible As Range
  30. Set cible = f_lo.Range("A2")
  31. Dim ligne As Range
  32. Dim acopier As Range
  33.  
  34. Dim feuille As Worksheet
  35.  
  36. For Each feuille In Array(f_pr, f_in, f_fr, f_li) 'message d'erreur 424 objet requis
  37. For Each ligne In feuille.Rows("1:500")
  38. If ligne.Cells(20).Value Like "*OBSO" Then
  39. Set acopier = Nothing
  40. For Each i In Array(1, 2, 3, 5, 6, 19, 20)
  41. Set acopier = IIf(acopier Is Nothing, ligne.Cells(i), Union(acopier, ligne.Cells(i)))
  42. Next
  43. acopier.Copy Destination:=cible
  44. Set cible = cible.Offset(1)
  45. End If
  46. Next
  47. Next
  48.  
  49.  
  50. Sheets("Extraction Obso").Select
  51. Range("A1").Select
  52. UserForm1.Hide
  53. End Sub
m
0
l
20 Février 2012 14:59:48

Oups.
Ce n'est pas ta faute.

C'est la mienne - un peu - car je n'ai pas vérifié.
Et c'est celle de Microsoft - beaucoup, énormément - parce que ces sal[:zeb:7]rds n'ont pas fini le modèle objet de leur langage.
:pfff: 

Bref.
De façon assez dégueulasse pas jolie, remplace la ligne 34 par :
  1. Dim feuille As Worksheet ' <-- Pas bon :(
  2. Dim feuille As Variant ' <-- Bon --- :( Quoi que
m
0
l
20 Février 2012 15:11:00

yes, j'ai trouvé aussi! en cherchant bien, des fois on trouve!! :) 

maintenant, je cherche la solution au nouveau message erreur.... lol
je suis en train de regarder dans l'aide ;) 

  1. Private Sub CommandButton8_Click()
  2. '
  3. ' // Préparation
  4.  
  5.  
  6. Dim f_pr As Worksheet ' // Feuille Procedure
  7. Dim f_in As Worksheet ' // Feuille Instruction
  8. Dim f_fr As Worksheet ' // Feuille Formulaire
  9. Dim f_li As Worksheet ' // Feuille Liste
  10. Dim f_lo As Worksheet ' // Feuille Extraction Obso
  11.  
  12. Set f_pr = Worksheets("Procedure")
  13. Set f_in = Worksheets("Instruction")
  14. Set f_fr = Worksheets("Formulaire")
  15. Set f_li = Worksheets("Liste")
  16. Set f_lo = Worksheets("Extraction Obso")
  17.  
  18.  
  19. 'nettoyage de la feuille
  20.  
  21. f_lo.Rows("2:500").Delete
  22.  
  23. 'définition des valeurs service et condition
  24. UserForm10.Show '// mets la valeurs de la condition en L2 de la Feuille Extraction Obso
  25. UserForm11.Show '// mets la valeurs du service émetteur en M2 de la Feuille Extraction Obso
  26.  
  27. ' définition de la cible
  28.  
  29. Dim cible As Range
  30. Set cible = f_lo.Range("A2")
  31. Dim ligne As Range
  32. Dim acopier As Range
  33.  
  34. Dim feuille As Variant
  35.  
  36. For Each feuille In Array(f_pr, f_in, f_fr, f_li)
  37. For Each ligne In feuille.Rows("1:500")
  38. If ligne.Cells(20).Value Like "*OBSO" Then
  39. Set acopier = Nothing
  40. For Each i In Array(1, 2, 3, 5, 6, 19, 20)
  41. Set acopier = IIf(acopier Is Nothing, ligne.Cells(i), Union(acopier, ligne.Cells(i))) 'message d'erreur 5 argument ou appel incorrect
  42. Next
  43. acopier.Copy Destination:=cible
  44. Set cible = cible.Offset(1)
  45. End If
  46. Next
  47. Next
  48.  
  49.  
  50. Sheets("Extraction Obso").Select
  51. Range("A1").Select
  52. UserForm1.Hide
  53. End Sub
m
0
l
20 Février 2012 15:58:18

Et Zut ! Là, c'est ma faute à ma tout seul :/ 
En fait, Union() est assez mal fichu.

A la ligne 41, j'aurai voulu écrire :
  1. acopier = acopier + ligne.Cells(i)

Pour ajouter une cellule à une plage.

Bon, en VB, ça s'écrit avec un Set et un Union(). :sarcastic: 
  1. Set acopier = Union(acopier, ligne.Cells(i))


Sauf que si acopier est vide, ça plante.

Donc j'ai voulu écrire :
  1. If acopier Is Nothing Then
  2. Set acopier = ligne.Cells(i)
  3. Else
  4. Set acopier = Union(acopier, ligne.Cells(i))
  5. End If


Comme il commençait à y avoir beaucoup de choses imbriquées, j'ai voulu jouer au plus malin en transformant le If .. Then .. Else en Iif().
Sauf que Iif() est une fonction et que tous les paramètres sont évalués avant que ne commence la fonction. Et donc le code plante sur le troisière paramètre quand acopier est vide, ce que justement je voulais éviter.

:honte:

Bon, dans ces cas-là, il faut soit accepter d'imbriquer beaucoup de choses, soit il faut créer une sous-fonction.
Je choisis la seconde solution pour rester cohérent avec moi-même.

Et je crée ma propre fonction Union(). Elle s'appelle zUnion() :sol: 

  1. Private Function zUnion(ParamArray range1()) As Range
  2. Dim result As Range
  3. Dim r As Variant
  4.  
  5. For Each r In range1
  6. If Not r Is Nothing Then
  7. If result Is Nothing Then
  8. Set result = r
  9. Else
  10. Set result = Union(result, r)
  11. End If
  12. End If
  13. Next
  14.  
  15. Set zUnion = result
  16. End Function


Et maintenant, la ligne 41 :
  1. Set acopier = Union(acopier, ligne.Cells(i))


Et voilou !
m
0
l
20 Février 2012 17:07:41

:bounce: 
impec, ça marche! Je te remercie énormément!

maintenant, je vais m'atteler à regarder ce que tu me disais sur un message précédent pour l'extraction avec une valeur se situant dans une cellule et aussi l'énormité que tu as relevé avec mes lignes (500)....

euh, petite question con d'une non informaticienne : l'envirronement (windows 7, xp...) peut jouer sur l'éxécution des macros?
m
0
l
21 Février 2012 11:23:00

Citation :
[..] ça marche! Je te remercie [..]

Ahhhh !Ça fait plaisir. :) 

Les macro-commandes sont associées à un logiciel - en l'occurrence Excel - pas à un système d'exploitation.
Attention cependant, il peut y avoir des différences entre les versions d'Excel.
Mais c'est très rare et la rétrocompatibilité est très importante pour les éditeurs comme Microsoft, quitte à reconduire exprès des bogues.
De Bill Gates cette maxime : It's not a bug, it's a feature.


En attendant la suite ...
:) 
m
0
l
21 Février 2012 15:07:41

ok, merci! je demandais ça car je rencontre beaucoup de problème de compatibilité entre les versions d'excel sur le parc informatique.
Les macros créées avec un excel 2000 ou 2003 ne marchent pas forcément sous 2010....
et je dois aussi gérer plusieurs versions d'un même fichier afin que toutes le monde puisse utiliser ces fichiers suivant leur versions d'excel!:pt1cable: 

pour la suite, se sera fin de semaine car là, je suis malade...:( 
m
0
l
22 Février 2012 09:42:06

[private]
Oh, pauv' nini :( 
Soigne-toi bien.
m
0
l
19 Mars 2012 17:10:17

hello!
bon, me revoilà reparti dans les macros!!! :)  après plus d'un mois sans y avoir touché une seule fois....
faut que je me remette dedans!

je suis, du coup, toujours au même point qu'avant, je cherche comment lui dire d'extraire les données non pas directement en lui mettant la condition mais qu'il aille la chercher dans une case la contenant.

mes conditions se trouve dans la feuille "Extraction Obso" avec la condition en "L2" et le service en "M2" qui y sont placé grâce à deux combobox.

  1. Private Sub CommandButton8_Click()
  2. '
  3. ' // Préparation
  4.  
  5.  
  6. Dim f_pr As Worksheet ' // Feuille Procedure
  7. Dim f_in As Worksheet ' // Feuille Instruction
  8. Dim f_fr As Worksheet ' // Feuille Formulaire
  9. Dim f_li As Worksheet ' // Feuille Liste
  10. Dim f_lo As Worksheet ' // Feuille Extraction Obso
  11.  
  12. Set f_pr = Worksheets("Procedure")
  13. Set f_in = Worksheets("Instruction")
  14. Set f_fr = Worksheets("Formulaire")
  15. Set f_li = Worksheets("Liste")
  16. Set f_lo = Worksheets("Extraction Obso")
  17.  
  18.  
  19. 'nettoyage de la feuille
  20.  
  21. f_lo.Rows("2:500").Delete
  22.  
  23. 'définition des valeurs service et condition
  24. UserForm10.Show '// mets la valeurs de la condition en L2 de la Feuille Extraction Obso
  25. UserForm11.Show '// mets la valeurs du service émetteur en M2 de la Feuille Extraction Obso
  26.  
  27. ' définition de la cible
  28.  
  29. Dim cible As Range
  30. Set cible = f_lo.Range("A2")
  31. Dim ligne As Range
  32. Dim acopier As Range
  33.  
  34. Dim feuille As Variant
  35.  
  36. For Each feuille In Array(f_pr, f_in, f_fr, f_li)
  37. For Each ligne In feuille.Rows("1:500")
  38. If ligne.Cells(20).Value Like "*OBSO" Then
  39. Set acopier = Nothing
  40. For Each i In Array(1, 2, 3, 5, 6, 19, 20)
  41. Set acopier = zUnion(acopier, ligne.Cells(i))
  42. Next
  43. acopier.Copy Destination:=cible
  44. Set cible = cible.Offset(1)
  45. End If
  46. Next
  47. Next
  48.  
  49.  
  50. Sheets("Extraction Obso").Select
  51. Range("A1").Select
  52. UserForm1.Hide
  53. End Sub


voilà, je me replonge dans ce monde afin de finaliser enfin cette partie de programme!

il faut que je modifie donc la ligne 38 du code avec ce que tu m'avais donné comme info :
Value = "MOT"
Où est MOT ?
Dans une cellule :
1.Value = feuille.Range("Xn")

Qu'est-ce que le service émetteur ?
Une autre colonne ?
Bon :
1.If ligne.Cells(20).Value = "MOT" And ligne.Cells(autre_colonne).Value = "service émetteur" Then ..

nini
m
0
l
20 Mars 2012 14:22:40

Salut Nini, ça va mieux ?

  1. Dim f_eo As Worksheet
  2. Set f_eo = Worksheets("Extraction Obso")
  3.  
  4. ...
  5.  
  6. If ligne.Cells(20).Value = f_eo.Range("L2").Value And _
  7. ligne.Cells(autre_colonne).Value = f_eo.Range("M2").Value Then ..


C'est ça qu'on cherche depuis 50 jours ?
Comprends pas ce qui n'est pas compréhensible.
C'est d'ailleurs toute la difficulté d'aider les autres ! :o 
m
0
l
21 Mars 2012 13:29:06

50 jours? euh, nan, juste depuis hier en fait et un peu avant que je sois malade mais je ne me souvenais plus du tout de ce que j'avais fait....
merci, je vais beaucoup mieux! ;) 
Mais tu es le meilleur, tu as compris parfaitement ce que je voulais faire! :sol: 
c'est vrai que c'est pas facile de s'exprimer par écrit sur ce genre de problème...désolée si je n'ai pas toujours été très claire!

j'avais fait ce que tu as mis mais j'avais un message erreur que je ne comprenais pas avant de voir le "_" derrière le And de ta ligne 6, tu peux me dire à quoi il sert?
m
0
l
5 Avril 2012 13:20:59

par contre, j'ai un problème quand la condition est "*OBSO", il ne m'extrait rien....
ça marche parfaitement avec la condition "OBSO" ou 'FUTUR OBSO" mais quand je lui demande "*OBSO", il ne comprend pas qu'il faut prendre qui contient OBSO? il y a une particularité pour ce cas là?
m
0
l
10 Avril 2012 15:43:00

Salut Nini,

A moi de t'abandonner pour cause de convalescence : 20 jours de repos forcé (ne joue jamais au Rugby, c'est un sport de brute !)
Mais me revoici !!!!

Le petit souligné [_] à la fin d'une ligne permet de passer à la ligne.
Le VBA est basé sur le BASIC, un langage archaïque dont il garde certains défauts. :spamafote: 

Quant à l'utilisation de l'astérisque
  • , il faut utiliser le comparateur Like et non pas l'habituel signe égal [=]
    Et bien vérifier que l'expression est bien déterminante.
    m
    0
    l