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

X

xalee

Nouveau membre
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...

Code: 
    Option Explicit 'là ça va
    Option Compare Text 'ça aide aussi

    Sub Recherche()
    Dim mot As Variant 'est-ce le bon choix?
    Dim feuille As Worksheet 'Dois-je entrer toutes les feuilles ici?
    Dim cellule As Range
    Dim ligne As Range
    Dim cible As Range
 
   
    mot = Application.InputBox("élément recherché:")
    Set feuille = Worksheets 'ça commence à buger dès que j'essaye de paramétrer la recherche sur plusieurs feuilles (Sheets seulement?)
    Set cible = Worksheets("Recherche").Range("A10") 'à compter de A10

    For Each ligne In feuille.UsedRange.Rows 'là je comprends "pour chaque ligne de la feuille (définie en début de code)"
    For Each cellule In ligne.Cells 'je lis "pour chaque cellule de la ligne testée" 
    If InStr(cellule.Text, mot) > 0 Then' Je lis si le nombre de mot trouvé est supérieur à 0
   
    ligne.Copy Destination:=cible '"La ligne est copié vers la cible" (définie au début du code)
    Set cible = cible.Offset(1) '"une fois collée; on descend d'une ligne" peut être me goure-je
    '// Pas la peine de continuer à chercher dans cette ligne
    Exit For
    End If
    Next
    Next
    ActiveSheet.Next.Cells.Columns.AutoFit 'là je ne comprends pas
    ActiveSheet.Next.Select 'là non plus
    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...) :)
 
X

xalee

Nouveau membre
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
Code: 
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
Code: 
    Private Sub Recherche_Initialize()
     Me.genre = True
    End Sub
    
    Option Explicit
    Option Compare Text
    Sub Ok_click()

    Dim mot As String
    
    Dim ligne As Range
    Dim cible As Range
    Dim acopier As Range
    Dim feuille As Variant
    Dim f_Zero As Worksheet
    Dim f_A As Worksheet
    Dim f_B As Worksheet
    Dim f_C As Worksheet
    Dim f_D As Worksheet
    Dim f_E As Worksheet
    Dim f_F As Worksheet
    
    Set f_Zero = Worksheets("Recherche")
    Set f_A = Worksheets("92-96")
    Set f_B = Worksheets("97-99")
    Set f_C = Worksheets("00-09")
    Set f_D = Worksheets("2010")
    Set f_E = Worksheets("2011")
    Set f_F = Worksheets("2012")
    
    Set cible = f_Zero.Range("A10")
    
   If Not Me.TextBox1.Value = "" Then
    If Me.genre = True Then
 
       For Each feuille In Array(f_A, f_B, f_C, f_D, f_E, f_F)
           For Each ligne In feuille.Rows("10:5000")
              If ligne.Cells(6).Value Like Me.TextBox1.Value Then
         Set acopier = Union(ligne.Cells(2), ligne.Cells(3), ligne.Cells(5), ligne.Cells(6), ligne.Cells(7), ligne.Cells(8))
'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,
' car il faut que la ligne corresponde à un critère que je n'arrive pas à définnir ("Set acopier=Rows(ligne)."???)

                  acopier.Copy Destination:=cible 'là j'ai du debug constant...
                  Set cible = cible.Offset(1)
                     End If
                
          Next
      Next
 
     End If
    End If
            Sheets("Recherche").Select
            Range("A1").Select
            Recherche.Hide
End Sub

Private Sub Cancel_Click()
Unload Recherche
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 :/
 
X

xalee

Nouveau membre
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...

Code: 
    Private Sub Recherche_Initialize()
     Me.genre = True
    End Sub
    
    Option Explicit
    Option Compare Text
    Sub Ok_click()

    Dim mot As Variant 'Peut être aussi bien un chiffre qu'un texte ou les deux
    
    Dim ligne As Range
    Dim cible As Range
    Dim acopier As Range
    Dim feuille As Variant
    
    Dim f_Zero As Worksheet
    Dim f_A As Worksheet
    Dim f_B As Worksheet
    Dim f_C As Worksheet
    Dim f_D As Worksheet
    Dim f_E As Worksheet
    Dim f_F As Worksheet
    
      Set f_A = Worksheets("92-96")
      Set f_B = Worksheets("97-99")
      Set f_C = Worksheets("00-09")
      Set f_D = Worksheets("2010")
      Set f_E = Worksheets("2011")
      Set f_F = Worksheets("2012")
    
    Set f_Zero = Worksheets("Recherche")
    Set cible = f_Zero.Range("A10")
    
    If Not Me.TextBox1.Value = "" Then 'Si ma boite de dialogue n'est pas vide
     If Me.genre = True Then 'Si "Genre" est coché
      
      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
          For Each ligne In feuille.Rows("10:5000") 'Pour chaque ligne allant de la 10ème à la 5000ème de chaque feuille testée
                If ligne.Cells(6).Value = Me.TextBox1.Value Then 'Si le contenu de la cellule en colonne "F" correspond à celle de ma textbox
                   Set acopier = Nothing 'alors "acopier" est défini par cette cellule
                   For Each i In ligne.Cells.Range("F10:F5000") 'Pour chaque cellule i contenue dans le Range F10:F5000"
                      Set acopier = IIf(acopier Is Nothing, ligne.Cells(i), Union(acopier, ligne.Cells(i))) 'Copier la ligne
                   Next
                      acopier.Copy Destination:=cible 'Vers la cible en "A10"
                      Set cible = cible.Offset(1)
                End If
          Next
      Next
 
     End If
    End If
            Sheets("Recherche").Select
            Range("A1").Select
            Recherche.Hide
    End Sub

Private Sub Cancel_Click()
Unload Recherche
End Sub

Rien à faire, ça ne passe pas et toujours go-debug ligne 40,42...
Mais je ne trouve pas l'erreur
 
X

xalee

Nouveau membre
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.

Code: 
 Private Sub Recherche_Click()
 
    Dim f_Zero As Worksheet
    Dim f_A As Worksheet
    Dim f_B As Worksheet
    Dim f_C As Worksheet
    Dim f_D As Worksheet
    Dim f_E As Worksheet
    Dim f_F As Worksheet
    
      Set f_A = Worksheets("92-96")
      Set f_B = Worksheets("97-99")
      Set f_C = Worksheets("00-09")
      Set f_D = Worksheets("2010")
      Set f_E = Worksheets("2011")
      Set f_F = Worksheets("2012")
      Set f_Zero = Worksheets("Recherche")

 
Dim mot As String
Dim feuille As Variant
Dim cellule As Range
Dim ligne As Range
Dim cible As Range
 
mot = Range("F9").Value
Set cible = f_Zero.Range("A10")

Application.ScreenUpdating = False
       

 For Each feuille In Array(f_A, f_B, f_C, f_D, f_E, f_F)
   For Each ligne In feuille.UsedRange.Rows
     For Each cellule In ligne.Cells
        If InStr(cellule.Text, mot) > 0 Then
'// On a trouvé le mot dans une cellule de la ligne
            On Error Resume Next 'Vu que certaines colonnes sont des listes...

        ligne.Copy Destination:=cible
        Set cible = cible.Offset(1)
'// Pas la peine de continuer à chercher dans cette ligne
        Exit For
        End If
     Next
   Next
 Next
 
 Application.ScreenUpdating = True
 
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 :(

 
X

xalee

Nouveau membre
Meilleure réponse
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:

Code: 
 Private Sub OK_Click()

    Dim f_Zero As Worksheet
    Dim f_A As Worksheet
    Dim f_B As Worksheet
    Dim f_C As Worksheet
    Dim f_D As Worksheet
    Dim f_E As Worksheet
    Dim f_F As Worksheet
    
      Set f_A = Worksheets("92-96")
      Set f_B = Worksheets("97-99")
      Set f_C = Worksheets("00-09")
      Set f_D = Worksheets("2010")
      Set f_E = Worksheets("2011")
      Set f_F = Worksheets("2012")
      Set f_Zero = Worksheets("Recherche")

    Dim mot1 As Variant
    Dim mot2 As Variant
    Dim x As Range
    Dim y As Range
    
    Dim mot As String
    Dim feuille As Variant
    Dim cellule As Range
    Dim ligne As Range
    Dim cible As Range
    
    mot1 = TextBox1.Value
    
    Set cible = f_Zero.Range("B10")
    
 '------------------------------------------------------
    
    If mot1 <> "" Then
    
    Application.ScreenUpdating = False
    
 '------------------------------------------------------
 '------------------------------------------------------
    If Genre.Value = True Then
       Set x = Range("G9") 'si la case "genre" est cochée, "x" correspond à la cellule G9
           'j'amerai si possible définier la colonne à tester par Set y = Ligne.cells(6)
           'et remplacer ligne.Cells(6) par y dans la ligne
       
       Call Reset 'remise à 0 de la feuille "rechercher"
       
         x.Value = mot1
         x.Interior.ColorIndex = xlNone
         x.Interior.ColorIndex = 1
         x.Font.ColorIndex = 2
         Unload Recherche
       
For Each feuille In Array(f_A, f_B, f_C, f_D, f_E, f_F)
   For Each ligne In feuille.UsedRange.Rows
     For Each cellule In ligne.Cells(6)
        If InStr(cellule.Text, mot1) > 0 Then
           ligne.Copy Destination:=cible
           Set cible = cible.Offset(1)

        Exit For
        End If
     Next
   Next
 Next
 
 '------------------------------------------------------
     Else
     If Tribe.Value = True Then
        Set x = Range("E9")
        
         Call Reset
    
         x = mot1
         x.Interior.ColorIndex = xlNone
         x.Interior.ColorIndex = 1
         x.Font.ColorIndex = 2
         Unload Recherche
           
For Each feuille In Array(f_A, f_B, f_C, f_D, f_E, f_F)
   For Each ligne In feuille.UsedRange.Rows
     For Each cellule In ligne.Cells(4)
        If InStr(cellule.Text, mot1) > 0 Then
           ligne.Copy Destination:=cible
           Set cible = cible.Offset(1)

        Exit For
        End If
     Next
   Next
 Next
 
 '------------------------------------------------------
      
      Else
      If sfam.Value = True Then
         Set x = Range("D9")
         
          Call Reset
    
          x = mot1
          x.Interior.ColorIndex = xlNone
          x.Interior.ColorIndex = 1
          x.Font.ColorIndex = 2
          Unload Recherche
           
For Each feuille In Array(f_A, f_B, f_C, f_D, f_E, f_F)
   For Each ligne In feuille.UsedRange.Rows
     For Each cellule In ligne.Cells(3)
        If InStr(cellule.Text, mot1) > 0 Then
           ligne.Copy Destination:=cible
           Set cible = cible.Offset(1)

        Exit For
        End If
     Next
   Next
 Next
 
 '------------------------------------------------------
       
       Else
       If Fam.Value = True Then
          Set x = Range("C9")
          
           Call Reset
    
           x = mot1
           x.Interior.ColorIndex = xlNone
           x.Interior.ColorIndex = 1
           x.Font.ColorIndex = 2
           Unload Recherche
           
For Each feuille In Array(f_A, f_B, f_C, f_D, f_E, f_F)
   For Each ligne In feuille.UsedRange.Rows
     For Each cellule In ligne.Cells(2)
        If InStr(cellule.Text, mot1) > 0 Then
           ligne.Copy Destination:=cible
           Set cible = cible.Offset(1)

        Exit For
        End If
     Next
   Next
 Next
 
 '------------------------------------------------------
        Else
        If Pays.Value = True Then
           Set x = Range("V9")
           
            Call Reset
    
            x = mot1
            x.Interior.ColorIndex = xlNone
            x.Interior.ColorIndex = 1
            x.Font.ColorIndex = 2
            Unload Recherche
    
For Each feuille In Array(f_A, f_B, f_C, f_D, f_E, f_F)
   For Each ligne In feuille.UsedRange.Rows
     For Each cellule In ligne.Cells(21)
        If InStr(cellule.Text, mot1) > 0 Then
           ligne.Copy Destination:=cible
           Set cible = cible.Offset(1)

        Exit For
        End If
     Next
   Next
 Next
 
 '------------------------------------------------------
    
         If Dep.Value = True Then
            Set x = Range("W9")
            
             Call Reset
    
             x = mot1
             x.Interior.ColorIndex = xlNone
             x.Interior.ColorIndex = 1
             x.Font.ColorIndex = 2
             Unload Recherche
    
For Each feuille In Array(f_A, f_B, f_C, f_D, f_E, f_F)
   For Each ligne In feuille.UsedRange.Rows
     For Each cellule In ligne.Cells(22)
        If InStr(cellule.Text, mot1) > 0 Then
           ligne.Copy Destination:=cible
           Set cible = cible.Offset(1)

        Exit For
        End If
     Next
   Next
 Next
 
 '------------------------------------------------------
    
          If Ref.Value = True Then
             Set x = Range("O9")
             
              Call Reset
    
              x = mot1
              x.Interior.ColorIndex = xlNone
              x.Interior.ColorIndex = 1
              x.Font.ColorIndex = 2
              Unload Recherche
    
For Each feuille In Array(f_A, f_B, f_C, f_D, f_E, f_F)
   For Each ligne In feuille.UsedRange.Rows
     For Each cellule In ligne.Cells(14)
        If InStr(cellule.Text, mot1) > 0 Then
           ligne.Copy Destination:=cible
           Set cible = cible.Offset(1)

        Exit For
        End If
     Next
   Next
 Next
 
 '------------------------------------------------------
    
           If Box.Value = True Then
              Set x = Range("AH9")
              
               Call Reset
    
               x = mot1
               x.Interior.ColorIndex = xlNone
               x.Interior.ColorIndex = 1
               x.Font.ColorIndex = 2
               Unload Recherche
              
For Each feuille In Array(f_A, f_B, f_C, f_D, f_E, f_F)
   For Each ligne In feuille.UsedRange.Rows
     For Each cellule In ligne.Cells(36)
        If InStr(cellule.Text, mot1) > 0 Then
           ligne.Copy Destination:=cible
           Set cible = cible.Offset(1)

        Exit For
        End If
     Next
   Next
 Next
 
 '------------------------------------------------------
              
           End If
          End If
         End If
        End If
       End If
      End If
     End If
     
    Application.ScreenUpdating = True
    
    End If
    End If
    
End Sub

Merci à vous :wahoo:
 
zeb

zeb

Modérateur
!

Merci à toi Xalee. :merci:

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:
 
Vous devez vous inscrire ou vous connecter pour répondre ici.
Dernières actus
Derniers messages publiés
Statistiques globales
Discussions
730 126
Messages
6 717 820
Membres
1 586 365
Dernier membre
matiOs1
Partager cette page
Haut