VB : copier coller sous conditions

[GhostInTheShell]

Bonjour,

Dans une feuille excel "Synthèse", j'ai une liste de personnes (Colonne D) identifiées par un code (Colonne Q - ex : *, **, ***). Je cherche désespérément à faire une macro qui, en fonction, du code de la colonne Q, copie / colle le Nom - Prénom de la personne dans un onglet "TCD" sachant que les * sont collés de la ligne 2 à 350, les ** de la ligne 352 à 702 et les *** de la ligne 704 à la ligne 1009.
Ensuite, j'ai une macro qui masquera les lignes vides.

J'ai essayé deux codes trouvés et adaptés :

Le premier :
Sub copiecellule()

Dim i As Integer
Dim y As Integer
i = 1

'Une boucle va faire la copie tant qu'il y aura des noms dans la première colonne
Do While (Range("I" & i) <> "")

'Selection de l'onglet ou se situe la liste non trier
Sheets("Tab saisie").Select

'Test pour savoir si la personne a accepte
If Range("BG" & i) <> "" Then
'Ici j'ai copier la ligne de A à H mais on peut changer ces colonnes ci dessous
Range("I" & i).Select
'Copie des données
Selection.Copy
'Selection de la feuil1 & collage
Sheets("Synthèse DD").Select
'On va à la 1ere ligne libre
y = 49
Do While (Range("A" & y) <> "")
y = y + 1
Loop
'Puis on colle au bon endroit
Range("A" & y).Select
ActiveSheet.Paste
End If

End Sub

Le second :

Sub copiecellule()

Dim A, B As Worksheet
Dim i, j As Integer
Set A = Sheets("Synthèse")
Set B = Sheets("TCD")

For i = 2 To 1000
If A.Cells(i, 17) = "**" Then
Copy B.Cells(j, 1)
j = j + 1
Next i
End If

End Sub

Avec le premier, j'ai un DO sans boucle et avec le second j'ai une erreur de compilationsub ou function non définie en ligne 8 (Copy....).

Pour masquer les lignes, j'ai un code qui fonctionne :

Sub Masquer()

Dim A As Worksheet
Dim i As Long

Set A = Sheets("TCD")
i = 1
Do While i < 58
If Cells(i, 1).Value = "" Then
Cells(i, 1).EntireRow.Hidden = True
End If
i = i + 1
Loop

End Sub

Merci par avance pour votre aide sur ce sujet

Cordialement,

 

[JNP]

Re : VB : copier coller sous conditions

Bonjour GhostInTheShell 🙂,
Soit dit sans te vexer, ton code est un beau boxif 😛...
Pour le premier code, c'est sûr que tu as 2 Do While et un seul Loop, donc ça ne peux pas le faire... mais en plus, tu jongles avec des cellules sans qu'on sache sur quelle feuille elles sont, ce qui risque de donner des résultats ératiques... Quelque chose comme ça devrait peut-être fonctionner

Sub copiecellule()
Dim i As Integer
Dim y As Integer
i = 1
'Une boucle va faire la copie tant qu'il y aura des noms dans la première colonne
Do While Sheets("Synthèse DD").Range("I" & i) <> ""
'Selection de l'onglet ou se situe la liste non trier
With Sheets("Tab saisie")
'Test pour savoir si la personne a accepte
If .Range("BG" & i) <> "" Then
'Ici j'ai copier la ligne de A à H mais on peut changer ces colonnes ci dessous
.Range("I" & i).Copy
End With
'Selection de la feuil1 & collage
With Sheets("Synthèse DD")
'On va à la 1ere ligne libre
y = 49
Do While .Range("A" & y) <> ""
y = y + 1
Loop
'Puis on colle au bon endroit
.Range("A" & y).Paste
End If
Loop
End Sub

pour le second, tu n'a pas précisé ce que tu voulais copier

Sub copiecellule()
Dim A, B As Worksheet
Dim i, j As Integer
Set A = Sheets("Synthèse")
Set B = Sheets("TCD")
For i = 2 To 1000
If A.Cells(i, 17) = "**" Then
[COLOR=red][B]A.Cells(i, [COLOR=yellowgreen]17[/COLOR]).[/B][/COLOR]Copy B.Cells(j, 1)
j = j + 1
Next i
End If
End Sub

le 17 est à changer avec le N° de colonne que tu veux copier.
Bonne soirée 😎

 

[GhostInTheShell]

Re : VB : copier coller sous conditions

Bonjour,

Merci beaucoup pour ton aide. Je vais essayer tout de suite et te donne des nouvelles.

Cordialement,

 

[GhostInTheShell]

Re : VB : copier coller sous conditions

Bonjour,

Effectivement, je n'ai pas fait attention sur le second code concernant la zone à copier.

Par contre, j'ai procédé à une légère modification :

Sub copiecellule()
Dim A, B As Worksheet
Dim i, j As Integer
Set A = Sheets("Synthèse")
Set B = Sheets("TCD")
j = 1
For i = 2 To 1000
If A.Cells(i, 17) = "2**" Then
A.Cells(i, 4).Copy B.Cells(j, 1)
j = j + 1
End If
Next
End Sub

J'ai paramétré mon j mais surtout j'ai remonté le End if. Maintenant cela fonctionne.

Je vais me pencher sur le premier code.

En tout cas grand merci.

Cordialement,