Discussion :

[anais83]

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.
A

Code :

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

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
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 !

[BENNASR]

Bonjour
tester avec prudence sur une copie

Code :

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

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
Sub Test()
Dim F1 As Worksheet
Dim F2 As Worksheet
Set F1 = Sheets("Feuil1")
Set F2 = Sheets("Feuil2")
Dim derlig As Long
Dim lig As Long
Application.ScreenUpdating = False
derlig = F1.Range("B" & Rows.Count).End(xlUp).Row
For L = 2 To derlig
If Left(F1.Cells(L, 2), 3) = "AAA" Then
lig = F2.Range("A" & Rows.Count).End(xlUp).Row + 1
F1.Cells(L, 2).Copy
F2.Cells(lig, 1).PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
ElseIf Left(F1.Cells(L, 2), 3) = "BBB" Then
lig = F2.Range("B" & Rows.Count).End(xlUp).Row + 1
F1.Cells(L, 2).Copy
F2.Cells(lig, 2).PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
ElseIf Left(F1.Cells(L, 2), 3) = "CCC" Then
lig = F2.Range("C" & Rows.Count).End(xlUp).Row + 1
F1.Cells(L, 2).Copy
F2.Cells(lig, 3).PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
End If
Next L
Application.ScreenUpdating = True
End Sub

[anais83]

Bonjour BENNASR!

Merci beaucoup pour ton retour ça fonctionne ( et bien mieux que le mien merci

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 ?
J'ai fait un exemple ci dessous pour être plus explicite

Merci bonne après midi

[BENNASR]

Attention ça n’efface pas les données de la feuille 2 avant l'exécution
tu peux effacer feuille2 avant d'envoyer les données avec :

Code :

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

1
2
3
4
F2.Cells.ClearContents
F2.Cells(2, 1) = "titre1"
F2.Cells(2, 3) = "titre2"
F2.Cells(2, 3) = "titre3"

ce qui donne :

Code :

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

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
Sub Test()
Dim F1 As Worksheet
Dim F2 As Worksheet
Set F1 = Sheets("Feuil1")
Set F2 = Sheets("Feuil2")
F2.Cells.ClearContents
F2.Cells(2, 1) = "titre1"
F2.Cells(2, 3) = "titre2"
F2.Cells(2, 3) = "titre3"
Dim derlig As Long
Dim lig As Long
Application.ScreenUpdating = False
derlig = F1.Range("B" & Rows.Count).End(xlUp).Row
For L = 2 To derlig
If Left(F1.Cells(L, 2), 3) = "AAA" Then
lig = F2.Range("A" & Rows.Count).End(xlUp).Row + 1
F1.Cells(L, 2).Copy
F2.Cells(lig, 1).PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
ElseIf Left(F1.Cells(L, 2), 3) = "BBB" Then
lig = F2.Range("B" & Rows.Count).End(xlUp).Row + 1
F1.Cells(L, 2).Copy
F2.Cells(lig, 2).PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
ElseIf Left(F1.Cells(L, 2), 3) = "CCC" Then
lig = F2.Range("C" & Rows.Count).End(xlUp).Row + 1
F1.Cells(L, 2).Copy
F2.Cells(lig, 3).PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
End If
Next L
Application.ScreenUpdating = True
End Sub

mais normalement la code respecte la chronologie

[anais83]

Oui elle respecte la chronologie colonne par colonne , mais ce que je voudrais c'est qu'à chaque fois qu'il y a un AAA elle passe à la ligne suivante pour remplir les AAA, BBB, et CCC. 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 petit exemple, mais je ne sais pas si je suis claire...



Merci pour ton aide en tout cas

[BENNASR]

mais si il trouve une seule AAA et ensuite 2 BBB ou 2 CCC ?????

si non

Code :

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

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
Sub Test()
Dim F1 As Worksheet
Dim F2 As Worksheet
Set F1 = Sheets("Feuil1")
Set F2 = Sheets("Feuil2")
F2.Cells.ClearContents
F2.Cells(2, 1) = "titre1"
F2.Cells(2, 2) = "titre2"
F2.Cells(2, 3) = "titre3"
Dim derlig As Long
Dim lig As Long
Application.ScreenUpdating = False
derlig = F1.Range("B" & Rows.Count).End(xlUp).Row
For L = 2 To derlig
lig = F2.Range("A" & Rows.Count).End(xlUp).Row + 1
If Left(F1.Cells(L, 2), 3) = "AAA" Then
F1.Cells(L, 2).Copy
F2.Cells(lig, 1).PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
ElseIf Left(F1.Cells(L, 2), 3) = "BBB" Then
'lig = F2.Range("B" & Rows.Count).End(xlUp).Row + 1
F1.Cells(L, 2).Copy
F2.Cells(lig, 2).PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
ElseIf Left(F1.Cells(L, 2), 3) = "CCC" Then
'lig = F2.Range("C" & Rows.Count).End(xlUp).Row + 1
F1.Cells(L, 2).Copy
F2.Cells(lig, 3).PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
End If
Next L
Application.ScreenUpdating = True
End Sub