Votre question
Résolu

VBA Excel, Recherche sur plusieurs feuilles d'un même classeur et copie de ligne

Tags :
  • Microsoft Excel
  • Programmation
Dernière réponse : dans Programmation
26 Mars 2012 21:15:22

Bonjour à tous,

Tout d'abord désolé de demander de l'aide en créant un Nième topic sur le sujet, mais là je suis réellement dans une impasse...

Je travaille sur un classeur d'inventaire faunistique qui se compose comme ceci:
- la première feuille me sert de recherche
- les autres regroupent les données à raison d'une feuille par année (Excel en Bdd ça n'est pas bien et je m'en excuse)

Toutes les feuilles (y compris "Recherche") ont la même structure:
Les données sont entrées dans le range B10:AH5000 de chaque feuille
Chaque ligne correspond à un individu et regroupe l'ensemble des éléments qui le caractérise
Chaque colonne correspond à un critère de classification (genre, espèce, taillle, mâle ou femelle, plante hôte, département....)

Je souhaite donc regrouper toutes les données de chaque feuille selon un critère précis pouvant être un mot (par exemple genre ou espèce), un chiffre (par exemple département), ou les deux (par exemple la référence CHR2010A21) sur ma feuille de recherche à partir de A10. Autrement dit regrouper par exemple toutes les data d'une même espèce.

Grand débutant en VBA, j'ai essayé des tas de programmes divers récupérés sur le net en essayant de les adapter sans succés... Dans un premier temps je pensais à un UserForme regroupant plusieurs critères mais rien à faire je nage.

Le code qui se rapproche le plus de ma recherche, je l'ai trouvé sur ce site. Par contre pour l'adapter mes neurones s'embrasent...

  1. Option Explicit 'là ça va
  2. Option Compare Text 'ça aide aussi
  3.  
  4. Sub Recherche()
  5. Dim mot As Variant 'est-ce le bon choix?
  6. Dim feuille As Worksheet 'Dois-je entrer toutes les feuilles ici?
  7. Dim cellule As Range
  8. Dim ligne As Range
  9. Dim cible As Range
  10.  
  11.  
  12. mot = Application.InputBox("élément recherché:")
  13. Set feuille = Worksheets 'ça commence à buger dès que j'essaye de paramétrer la recherche sur plusieurs feuilles (Sheets seulement?)
  14. Set cible = Worksheets("Recherche").Range("A10") 'à compter de A10
  15.  
  16. For Each ligne In feuille.UsedRange.Rows 'là je comprends "pour chaque ligne de la feuille (définie en début de code)"
  17. For Each cellule In ligne.Cells 'je lis "pour chaque cellule de la ligne testée"
  18. If InStr(cellule.Text, mot) > 0 Then' Je lis si le nombre de mot trouvé est supérieur à 0
  19.  
  20. ligne.Copy Destination:=cible '"La ligne est copié vers la cible" (définie au début du code)
  21. Set cible = cible.Offset(1) '"une fois collée; on descend d'une ligne" peut être me goure-je
  22. '// Pas la peine de continuer à chercher dans cette ligne
  23. Exit For
  24. End If
  25. Next
  26. Next
  27. ActiveSheet.Next.Cells.Columns.AutoFit 'là je ne comprends pas
  28. ActiveSheet.Next.Select 'là non plus
  29. End Sub


Bref à défaut d'avoir le programme complet, surtout que j'aimerai comprendre son fonctionnement, pourriez-vous me donner une piste?
Jusque là j'ai réussi à adapter toutes les macro dont j'ai besoin, mais celle-là me donne des suées.
Merci d'avance pour votre patience (et votre aide...) :) 

Autres pages sur : vba excel recherche plusieurs feuilles classeur copie ligne

27 Mars 2012 01:42:54

Bon au final, je suis tombé sur une file très instructive un peu plus bas, une personne ayant presque le même problème que moi...

Donc me revoilà parti sur un UseForm! :pt1cable: 

Tout est presque limpide pour moi, c'est presque miraculeux, enfin presque....

Je suis embêté sur
  1. copy destination
ou un message d'erreur apparaît :( 
Donc de nouveau coincé...

J'ai fait le test uniquement sur un critère ("Genre", à chercher dans le Range ("F10:F5000" de chaque feuille), donc le code n'est pas fini
  1. Private Sub Recherche_Initialize()
  2. Me.genre = True
  3. End Sub
  4.  
  5. Option Explicit
  6. Option Compare Text
  7. Sub Ok_click()
  8.  
  9. Dim mot As String
  10.  
  11. Dim ligne As Range
  12. Dim cible As Range
  13. Dim acopier As Range
  14. Dim feuille As Variant
  15. Dim f_Zero As Worksheet
  16. Dim f_A As Worksheet
  17. Dim f_B As Worksheet
  18. Dim f_C As Worksheet
  19. Dim f_D As Worksheet
  20. Dim f_E As Worksheet
  21. Dim f_F As Worksheet
  22.  
  23. Set f_Zero = Worksheets("Recherche")
  24. Set f_A = Worksheets("92-96")
  25. Set f_B = Worksheets("97-99")
  26. Set f_C = Worksheets("00-09")
  27. Set f_D = Worksheets("2010")
  28. Set f_E = Worksheets("2011")
  29. Set f_F = Worksheets("2012")
  30.  
  31. Set cible = f_Zero.Range("A10")
  32.  
  33. If Not Me.TextBox1.Value = "" Then
  34. If Me.genre = True Then
  35.  
  36. For Each feuille In Array(f_A, f_B, f_C, f_D, f_E, f_F)
  37. For Each ligne In feuille.Rows("10:5000")
  38. If ligne.Cells(6).Value Like Me.TextBox1.Value Then
  39. Set acopier = Union(ligne.Cells(2), ligne.Cells(3), ligne.Cells(5), ligne.Cells(6), ligne.Cells(7), ligne.Cells(8))
  40. 'là je n'ai rien touché, mais en fait c'est toute la ligne que je dois copier et je n'arrive pas à la codé correctement,
  41. ' car il faut que la ligne corresponde à un critère que je n'arrive pas à définnir ("Set acopier=Rows(ligne)."???)
  42.  
  43. acopier.Copy Destination:=cible 'là j'ai du debug constant...
  44. Set cible = cible.Offset(1)
  45. End If
  46.  
  47. Next
  48. Next
  49.  
  50. End If
  51. End If
  52. Sheets("Recherche").Select
  53. Range("A1").Select
  54. Recherche.Hide
  55. End Sub
  56.  
  57. Private Sub Cancel_Click()
  58. Unload Recherche
  59. End Sub


Je sens que je brûle, mais je ne sais pas si c'est parceque je m'en approche, ou c'est mon cerveau qui boue car il a atteint ses limites :/ 
m
0
l
27 Mars 2012 19:27:04

Bon, maintenant que ma tête a un peu refroidi (quoique), on est reparti!

J'ai intégralement lu la file où se trouve ce code et ai essayé de la comprendre pour l'adapter...

  1. Private Sub Recherche_Initialize()
  2. Me.genre = True
  3. End Sub
  4.  
  5. Option Explicit
  6. Option Compare Text
  7. Sub Ok_click()
  8.  
  9. Dim mot As Variant 'Peut être aussi bien un chiffre qu'un texte ou les deux
  10.  
  11. Dim ligne As Range
  12. Dim cible As Range
  13. Dim acopier As Range
  14. Dim feuille As Variant
  15.  
  16. Dim f_Zero As Worksheet
  17. Dim f_A As Worksheet
  18. Dim f_B As Worksheet
  19. Dim f_C As Worksheet
  20. Dim f_D As Worksheet
  21. Dim f_E As Worksheet
  22. Dim f_F As Worksheet
  23.  
  24. Set f_A = Worksheets("92-96")
  25. Set f_B = Worksheets("97-99")
  26. Set f_C = Worksheets("00-09")
  27. Set f_D = Worksheets("2010")
  28. Set f_E = Worksheets("2011")
  29. Set f_F = Worksheets("2012")
  30.  
  31. Set f_Zero = Worksheets("Recherche")
  32. Set cible = f_Zero.Range("A10")
  33.  
  34. If Not Me.TextBox1.Value = "" Then 'Si ma boite de dialogue n'est pas vide
  35. If Me.genre = True Then 'Si "Genre" est coché
  36.  
  37. For Each feuille In Array(f_A, f_B, f_C, f_D, f_E, f_F) 'Dans les feuilles nommées et déclarées
  38. For Each ligne In feuille.Rows("10:5000") 'Pour chaque ligne allant de la 10ème à la 5000ème de chaque feuille testée
  39. If ligne.Cells(6).Value = Me.TextBox1.Value Then 'Si le contenu de la cellule en colonne "F" correspond à celle de ma textbox
  40. Set acopier = Nothing 'alors "acopier" est défini par cette cellule
  41. For Each i In ligne.Cells.Range("F10:F5000") 'Pour chaque cellule i contenue dans le Range F10:F5000"
  42. Set acopier = IIf(acopier Is Nothing, ligne.Cells(i), Union(acopier, ligne.Cells(i))) 'Copier la ligne
  43. Next
  44. acopier.Copy Destination:=cible 'Vers la cible en "A10"
  45. Set cible = cible.Offset(1)
  46. End If
  47. Next
  48. Next
  49.  
  50. End If
  51. End If
  52. Sheets("Recherche").Select
  53. Range("A1").Select
  54. Recherche.Hide
  55. End Sub
  56.  
  57. Private Sub Cancel_Click()
  58. Unload Recherche
  59. End Sub


Rien à faire, ça ne passe pas et toujours go-debug ligne 40,42...
Mais je ne trouve pas l'erreur
m
0
l
Contenus similaires
29 Mars 2012 13:05:42

Ne trouvant toujours pas de solution malgré de nombreuses tentatives, j'ai modifié complètement ce que je souhaitais faire à l'origine....

donc maintenant je souhaite copier dans ma feuille "recherche" toutes les lignes des autres feuilles qui contiennent un mot contenu en F10 de cette feuille, et ça ne fonctionne toujours pas.

  1. Private Sub Recherche_Click()
  2.  
  3. Dim f_Zero As Worksheet
  4. Dim f_A As Worksheet
  5. Dim f_B As Worksheet
  6. Dim f_C As Worksheet
  7. Dim f_D As Worksheet
  8. Dim f_E As Worksheet
  9. Dim f_F As Worksheet
  10.  
  11. Set f_A = Worksheets("92-96")
  12. Set f_B = Worksheets("97-99")
  13. Set f_C = Worksheets("00-09")
  14. Set f_D = Worksheets("2010")
  15. Set f_E = Worksheets("2011")
  16. Set f_F = Worksheets("2012")
  17. Set f_Zero = Worksheets("Recherche")
  18.  
  19.  
  20. Dim mot As String
  21. Dim feuille As Variant
  22. Dim cellule As Range
  23. Dim ligne As Range
  24. Dim cible As Range
  25.  
  26. mot = Range("F9").Value
  27. Set cible = f_Zero.Range("A10")
  28.  
  29. Application.ScreenUpdating = False
  30.  
  31.  
  32. For Each feuille In Array(f_A, f_B, f_C, f_D, f_E, f_F)
  33. For Each ligne In feuille.UsedRange.Rows
  34. For Each cellule In ligne.Cells
  35. If InStr(cellule.Text, mot) > 0 Then
  36. '// On a trouvé le mot dans une cellule de la ligne
  37. On Error Resume Next 'Vu que certaines colonnes sont des listes...
  38.  
  39. ligne.Copy Destination:=cible
  40. Set cible = cible.Offset(1)
  41. '// Pas la peine de continuer à chercher dans cette ligne
  42. Exit For
  43. End If
  44. Next
  45. Next
  46. Next
  47.  
  48. Application.ScreenUpdating = True
  49.  
  50. End Sub


N'ayant toujours pas eu de réponse ou de piste je suis tenté de rendre les armes après plus d'une semaine de recherche infructueuse :( 

m
0
l

Meilleure solution

1 Avril 2012 23:27:46

Bonjour à tous, à force j'ai fini par y arriver :bounce: 

Donc MERCI à ce forum pour les innombrables trucs et astuces qu'il recèle, et merci à Zeb, vu qu'il s'agit en fait de différents codes qu'il a concocté et que je n'ai fait qu'adapter à mes besoins.

Le principale problème venait du fait que certaine colonnes étaient comprises dans des listes... erreur 1004 exécution impossible [...]. Si par hasard vous connaissez un moyen de contourner le problème (en fait ça n'a pas vriament d'importance, mais juste histoire d'en savoir un peu plus...

Bref voilà le code, et celui-ci fonctionne nikel. J'aimerai cependant le compacter un peu plus, mais je n'arrive pas à faire mieux.

Donc même si ça n'est pas urgent, si vous avez une solution je suis preneur. Tout est compris dans un Userforme, en fonction du choix du type de recherche la colonne à tester sera différente.

Jugez vous-même:

  1. Private Sub OK_Click()
  2.  
  3. Dim f_Zero As Worksheet
  4. Dim f_A As Worksheet
  5. Dim f_B As Worksheet
  6. Dim f_C As Worksheet
  7. Dim f_D As Worksheet
  8. Dim f_E As Worksheet
  9. Dim f_F As Worksheet
  10.  
  11. Set f_A = Worksheets("92-96")
  12. Set f_B = Worksheets("97-99")
  13. Set f_C = Worksheets("00-09")
  14. Set f_D = Worksheets("2010")
  15. Set f_E = Worksheets("2011")
  16. Set f_F = Worksheets("2012")
  17. Set f_Zero = Worksheets("Recherche")
  18.  
  19. Dim mot1 As Variant
  20. Dim mot2 As Variant
  21. Dim x As Range
  22. Dim y As Range
  23.  
  24. Dim mot As String
  25. Dim feuille As Variant
  26. Dim cellule As Range
  27. Dim ligne As Range
  28. Dim cible As Range
  29.  
  30. mot1 = TextBox1.Value
  31.  
  32. Set cible = f_Zero.Range("B10")
  33.  
  34. '------------------------------------------------------
  35.  
  36. If mot1 <> "" Then
  37.  
  38. Application.ScreenUpdating = False
  39.  
  40. '------------------------------------------------------
  41. '------------------------------------------------------
  42. If Genre.Value = True Then
  43. Set x = Range("G9") 'si la case "genre" est cochée, "x" correspond à la cellule G9
  44. 'j'amerai si possible définier la colonne à tester par Set y = Ligne.cells(6)
  45. 'et remplacer ligne.Cells(6) par y dans la ligne
  46.  
  47. Call Reset 'remise à 0 de la feuille "rechercher"
  48.  
  49. x.Value = mot1
  50. x.Interior.ColorIndex = xlNone
  51. x.Interior.ColorIndex = 1
  52. x.Font.ColorIndex = 2
  53. Unload Recherche
  54.  
  55. For Each feuille In Array(f_A, f_B, f_C, f_D, f_E, f_F)
  56. For Each ligne In feuille.UsedRange.Rows
  57. For Each cellule In ligne.Cells(6)
  58. If InStr(cellule.Text, mot1) > 0 Then
  59. ligne.Copy Destination:=cible
  60. Set cible = cible.Offset(1)
  61.  
  62. Exit For
  63. End If
  64. Next
  65. Next
  66. Next
  67.  
  68. '------------------------------------------------------
  69. Else
  70. If Tribe.Value = True Then
  71. Set x = Range("E9")
  72.  
  73. Call Reset
  74.  
  75. x = mot1
  76. x.Interior.ColorIndex = xlNone
  77. x.Interior.ColorIndex = 1
  78. x.Font.ColorIndex = 2
  79. Unload Recherche
  80.  
  81. For Each feuille In Array(f_A, f_B, f_C, f_D, f_E, f_F)
  82. For Each ligne In feuille.UsedRange.Rows
  83. For Each cellule In ligne.Cells(4)
  84. If InStr(cellule.Text, mot1) > 0 Then
  85. ligne.Copy Destination:=cible
  86. Set cible = cible.Offset(1)
  87.  
  88. Exit For
  89. End If
  90. Next
  91. Next
  92. Next
  93.  
  94. '------------------------------------------------------
  95.  
  96. Else
  97. If sfam.Value = True Then
  98. Set x = Range("D9")
  99.  
  100. Call Reset
  101.  
  102. x = mot1
  103. x.Interior.ColorIndex = xlNone
  104. x.Interior.ColorIndex = 1
  105. x.Font.ColorIndex = 2
  106. Unload Recherche
  107.  
  108. For Each feuille In Array(f_A, f_B, f_C, f_D, f_E, f_F)
  109. For Each ligne In feuille.UsedRange.Rows
  110. For Each cellule In ligne.Cells(3)
  111. If InStr(cellule.Text, mot1) > 0 Then
  112. ligne.Copy Destination:=cible
  113. Set cible = cible.Offset(1)
  114.  
  115. Exit For
  116. End If
  117. Next
  118. Next
  119. Next
  120.  
  121. '------------------------------------------------------
  122.  
  123. Else
  124. If Fam.Value = True Then
  125. Set x = Range("C9")
  126.  
  127. Call Reset
  128.  
  129. x = mot1
  130. x.Interior.ColorIndex = xlNone
  131. x.Interior.ColorIndex = 1
  132. x.Font.ColorIndex = 2
  133. Unload Recherche
  134.  
  135. For Each feuille In Array(f_A, f_B, f_C, f_D, f_E, f_F)
  136. For Each ligne In feuille.UsedRange.Rows
  137. For Each cellule In ligne.Cells(2)
  138. If InStr(cellule.Text, mot1) > 0 Then
  139. ligne.Copy Destination:=cible
  140. Set cible = cible.Offset(1)
  141.  
  142. Exit For
  143. End If
  144. Next
  145. Next
  146. Next
  147.  
  148. '------------------------------------------------------
  149. Else
  150. If Pays.Value = True Then
  151. Set x = Range("V9")
  152.  
  153. Call Reset
  154.  
  155. x = mot1
  156. x.Interior.ColorIndex = xlNone
  157. x.Interior.ColorIndex = 1
  158. x.Font.ColorIndex = 2
  159. Unload Recherche
  160.  
  161. For Each feuille In Array(f_A, f_B, f_C, f_D, f_E, f_F)
  162. For Each ligne In feuille.UsedRange.Rows
  163. For Each cellule In ligne.Cells(21)
  164. If InStr(cellule.Text, mot1) > 0 Then
  165. ligne.Copy Destination:=cible
  166. Set cible = cible.Offset(1)
  167.  
  168. Exit For
  169. End If
  170. Next
  171. Next
  172. Next
  173.  
  174. '------------------------------------------------------
  175.  
  176. If Dep.Value = True Then
  177. Set x = Range("W9")
  178.  
  179. Call Reset
  180.  
  181. x = mot1
  182. x.Interior.ColorIndex = xlNone
  183. x.Interior.ColorIndex = 1
  184. x.Font.ColorIndex = 2
  185. Unload Recherche
  186.  
  187. For Each feuille In Array(f_A, f_B, f_C, f_D, f_E, f_F)
  188. For Each ligne In feuille.UsedRange.Rows
  189. For Each cellule In ligne.Cells(22)
  190. If InStr(cellule.Text, mot1) > 0 Then
  191. ligne.Copy Destination:=cible
  192. Set cible = cible.Offset(1)
  193.  
  194. Exit For
  195. End If
  196. Next
  197. Next
  198. Next
  199.  
  200. '------------------------------------------------------
  201.  
  202. If Ref.Value = True Then
  203. Set x = Range("O9")
  204.  
  205. Call Reset
  206.  
  207. x = mot1
  208. x.Interior.ColorIndex = xlNone
  209. x.Interior.ColorIndex = 1
  210. x.Font.ColorIndex = 2
  211. Unload Recherche
  212.  
  213. For Each feuille In Array(f_A, f_B, f_C, f_D, f_E, f_F)
  214. For Each ligne In feuille.UsedRange.Rows
  215. For Each cellule In ligne.Cells(14)
  216. If InStr(cellule.Text, mot1) > 0 Then
  217. ligne.Copy Destination:=cible
  218. Set cible = cible.Offset(1)
  219.  
  220. Exit For
  221. End If
  222. Next
  223. Next
  224. Next
  225.  
  226. '------------------------------------------------------
  227.  
  228. If Box.Value = True Then
  229. Set x = Range("AH9")
  230.  
  231. Call Reset
  232.  
  233. x = mot1
  234. x.Interior.ColorIndex = xlNone
  235. x.Interior.ColorIndex = 1
  236. x.Font.ColorIndex = 2
  237. Unload Recherche
  238.  
  239. For Each feuille In Array(f_A, f_B, f_C, f_D, f_E, f_F)
  240. For Each ligne In feuille.UsedRange.Rows
  241. For Each cellule In ligne.Cells(36)
  242. If InStr(cellule.Text, mot1) > 0 Then
  243. ligne.Copy Destination:=cible
  244. Set cible = cible.Offset(1)
  245.  
  246. Exit For
  247. End If
  248. Next
  249. Next
  250. Next
  251.  
  252. '------------------------------------------------------
  253.  
  254. End If
  255. End If
  256. End If
  257. End If
  258. End If
  259. End If
  260. End If
  261.  
  262. Application.ScreenUpdating = True
  263.  
  264. End If
  265. End If
  266.  
  267. End Sub


Merci à vous :wahoo: 
partage
a b L Programmation
10 Avril 2012 12:24:09

!

Merci à toi Xalee. :jap: 

Je rentre aujourd'hui de convalescence.

En lisant ton premier message, je me disais - rapport à ton état d'esprit - "ah zut, en voilà un à qui j'aurais aimé donner un coup de main".

A finir la lecture de tout tes messages, je me rends compte que j'ai pu y contribuer quand même.
:bounce: 
m
0
l