VBA_rechercher une valeur dans une liste + copier coller dans un tableau

Bonjour à tous,

Je vous sollicite car après de nombreux essais la macro que j'ai adapté ne fonctionne toujours pas, et peut être que vous aurez une piste pour m'aider !

En Feuil1 , j'ai une liste de valeurs dans une colonne "B" si les 3 premiers caractères sont : "AAA", "BBB", "CCC" , je souhaite copier coller la valeur de la cellule dans un tableau en feuille 2. ( Les AAA dans la colonne A, les BBB dans la Colonne B , CCC dans la colonne C)

Il faudrait que la macro lise la liste, et à chaque fois qu'elle identifie un AAA qu'elle passe à la ligne suivante du tableau et qu'elle remplisse le tableau avec les informations de AAA , BBB et CCC. Sachant qu'il est possible qu'il n' y ait pas de BBB ou de CCC pour un AAA.

Vous trouverez ci dessous le code et le fichier que j'utilise pour le moment.

Sub CutData()
Application.ScreenUpdating = False
Dim MotCle
Dim i As Byte
Dim C As Range
Dim F As String
Dim Ligne As Long
    'On définit les mots clés
    MotCle = Array("AAA", "BBB", "CCC")
    'On effectue la recherche de chaque mot clé dans la colonne A de la Feuil1
    For i = 0 To UBound(MotCle)
        Do
            Set C = Worksheets("Feuil1").Columns(1).Find(MotCle(i), LookIn:=xlValues, lookat:=xlPart)
            'Si le mot clé est trouvé
            If Not C Is Nothing Then
                'On définit le nom de la feuille où sera effectuée la copie
                F = "Feuil2" & (i + 2)
                With Worksheets("Feuil2")
                    'On définit la ligne et la colonne où sera effectué le collage
                    Ligne = .Range("F" & Rows.Count).End(xlUp).Row + 1

                    'On effectue le copier / coller de la cellule
                    C.Cells.Copy .Range("A" & Ligne)

                End With
            End If
        Loop While Not C Is Nothing
    Next i
    Application.ScreenUpdating = True 'Facultatif
End Sub

Merci de m'avoir lue et pour votre aide !

A

Bonjour à tous!

Anais83, comme ceci

Option Compare Text
Sub CutData()
Dim F1, F2 As Worksheet
Set F1 = Worksheets("Feuil1")
Set F2 = Worksheets("Feuil2")
dl = F1.Range("A" & Rows.Count).End(xlUp).Row
Application.ScreenUpdating = False
For i = 1 To dl
If Left(F1.Cells(i, 1), 3) = "aaa" Then
F1.Cells(i, 1).Copy Destination:=F2.Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
End If
If Left(F1.Cells(i, 1), 3) = "bbb" Then
F1.Cells(i, 1).Copy Destination:=F2.Range("B" & Rows.Count).End(xlUp).Offset(1, 0)
End If
If Left(F1.Cells(i, 1), 3) = "ccc" Then
F1.Cells(i, 1).Copy Destination:=F2.Range("C" & Rows.Count).End(xlUp).Offset(1, 0)
End If
Next i
Application.ScreenUpdating = True
End Sub

Renommer les feuilles à ta convenance...

Bonne journée!

Bonjour NordiK_Nation !

Merci beaucoup pour ton retour ça marche déjà (vraiment beaucoup )mieux que mon code :D

Par contre juste un petit détail, est il possible de faire en sorte que la macro suive la chronologie de la liste. Que lorsqu'elle "rencontre un AAA" dans la liste elle passe à la ligne suivante pour remplir le tableau ? Enfaite les BBB et les CCC doivent être sur la même ligne dans le tableau que le AAA qui les précède dans la liste.
J'ai fait un exemple ci dessous pour être plus explicite :)

Merci :)

Bonjour à tous,

C'est le genre de problème où vous nous dites pas tout et qui ne doit pas refléter réellement votre problématique Anaïs.

Des trous dans votre liste, aligner les données selon quel critère et j'en passe sûrement !!!

Je sens que l'on va tourner en rond longtemps

Si votre problématique est vraiment celle exposée, je procéderais comme ceci.

Je pré-remplierais votre tableau de droite avec toutes les données pouvant y figurer, puis y effacerais les données qui ne sont pas dans votre liste de gauche via un dictionnaire.

Klin89

Bonjour Anais83, le Fil,

Avec le code ci-dessous. Par l'emploi de Case et du Flag Lin

Sub Cut()
Dim Der, LinA, LinB, LinC as Long.
Dim Lin as Byte
Der = Range("A" & Rows.Count).End(xlUp).Row
LinA = 2: LinB = 2: LinC = 2
For Lig = 2 To Der
Lin = 1
Select Case Left(Range("A" & Lig), 3)
Case "AAA"
LinA = LinA + 1: col = 3
Case "BBB"
LinB = LinB + 1: col = 4
Case "CCC"
LinC = LinC + 1: col = 5
Case Else
Lin = 0
End Select
If Lin > 0 Then Range("A" & Lig).Copy Sheets("Copie").Cells(Choose(col - 2, LinA, LinB, LinC), col)
Next Lig
End Su1

Note: Adapter au nom de la 2ième feuille. La macro se lance en étant sur la 1ière feuille.

Bonjour à tous !

Anais83, dans le fichier joint j'ai placé les 2 propositions celle de X Cellus que je salue au passage et la mienne qui semble convenir à ta demande elle vérifie seulement les "AAA" en respectant les 2 cellules suivantes. Vois si cela te convient. Un retour serait apprécié !

Bonne journée !

Bonjour à tous !

@Klin89, vous avez raison je n'ai pas était assez explicite sur ce sujet , je suis désolée , je tiendrais compte de votre point pour la prochaine fois

@Xcellus, merci beaucoup pour le code , mais elle ne permet pas dans le tableau de mettre les BBB et les CCC sur la même ligne que le AAA qui les précède dans la liste.

@NordiK_Nation, merci ta macro réponds parfaitement à ce que je cherchais ! tu sauves ma semaine :) , merci pour ton temps et ton aide :)

Merci à tous pour votre aide ! je vous souhaite une bonne journée :)

A

Bonjour à tous !

Merci du retour |