Ceci est une page optimisée pour les mobiles. Cliquez sur ce texte pour afficher la vraie page.

Autre façon de copier...

Bruno2019

XLDnaute Nouveau
Bonjour à tous,

J'ai créé un fichier permettant de rechercher et de sélectionner des lignes de références pour les insérer dans un tableau.

Le débutant que je suis utilise cette méthode (voir ci-dessous) mais j'ai le sentiment qu'il y a plus simple et moins gourmand en ressources. Le but étant, vous l'aurez compris, de copier des cellules non conjointes vers une même ligne (la première ligne dispo).

VB:
Sub ajouter()
ActiveSheet.Unprotect "MotDePasse"
If Application.IsNA(Range("N7").Value) Then
MsgBox ("Veuillez sélectionner des caractéristiques valides !")
Exit Sub
End If
If Range("N7") = "Indisponible" Then
MsgBox ("Les caractéristiques sélectionnées ne correspondent à aucun disjoncteur !")
Exit Sub
End If
If Range("D4") <> "" And Range("D7") <> "" And Range("F7") <> "" And Range("H7") <> "" And Range("J7") <> "" And Range("L7") <> "" And Range("N7") <> "Indisponible" Then
Range("D4").Copy
Sheets("Choix").Range("S" & Range("S" & Rows.Count).End(xlUp).Row + 1).PasteSpecial Paste:=xlPasteValues
Range("D7").Copy
Sheets("Choix").Range("T" & Range("S" & Rows.Count).End(xlUp).Row + 0).PasteSpecial Paste:=xlPasteValues
Range("F7").Copy
Sheets("Choix").Range("U" & Range("S" & Rows.Count).End(xlUp).Row + 0).PasteSpecial Paste:=xlPasteValues
Range("H7").Copy
Sheets("Choix").Range("V" & Range("S" & Rows.Count).End(xlUp).Row + 0).PasteSpecial Paste:=xlPasteValues
Range("J7").Copy
Sheets("Choix").Range("W" & Range("S" & Rows.Count).End(xlUp).Row + 0).PasteSpecial Paste:=xlPasteValues
Range("L7").Copy
Sheets("Choix").Range("X" & Range("S" & Rows.Count).End(xlUp).Row + 0).PasteSpecial Paste:=xlPasteValues
Range("N7").Copy
Sheets("Choix").Range("Y" & Range("S" & Rows.Count).End(xlUp).Row + 0).PasteSpecial Paste:=xlPasteValues
Else
MsgBox ("Veuillez sélectionner des caractéristiques valides !")
End If
ActiveSheet.Protect "MotDePasse"
End Sub

Ce code fonctionne mais je suis à l'écoute de toute solution qui serait plus... académique !

Merci.
 
Solution
Bonjour à tous,

Vaut mieux joindre un fichier!

Code:
Sub ajouter()
ActiveSheet.Unprotect "MotDePasse"
If Application.IsNA(Range("N7").Value) Then
MsgBox ("Veuillez sélectionner des caractéristiques valides !")
Exit Sub
End If
If Range("N7") = "Indisponible" Then
MsgBox ("Les caractéristiques sélectionnées ne correspondent à aucun disjoncteur !")
Exit Sub
End If
If Range("D4") <> "" And Range("D7") <> "" And Range("F7") <> "" And Range("H7") <> "" And Range("J7") <> "" _
And Range("L7") <> "" And Range("N7") <> "Indisponible" Then
Range("D4").Copy
Sheets("Choix").Range("S" & Range("S" & Rows.Count).End(xlUp).Row + 1).PasteSpecial _
Paste:=xlPasteValues
'// Sélection multiple et collage unique
Range("D7,F7,H7,J7,L7,N7").Copy...

xUpsilon

XLDnaute Accro
Bonjour,

Une petite boucle pour alléger ce qui peut l'être
VB:
If Range("D4") <> "" And Range("D7") <> "" And Range("F7") <> "" And Range("H7") <> "" And Range("J7") <> "" And Range("L7") <> "" And Range("N7") <> "Indisponible" Then
Range("D4").Copy
Sheets("Choix").Range("S" & Range("S" & Rows.Count).End(xlUp).Row + 1).PasteSpecial Paste:=xlPasteValues
For i = 0 to 5
Cells(7,i*2 + 4).Copy
Sheets("Choix").Cells(Range("S" & Rows.Count.End(xlUp).Row), 20 + i).PasteSpecial Paste:=xlPasteValues
Next i
Else
MsgBox ("Veuillez sélectionner des caractéristiques valides !")
End If

Bonne continuation
 

kingfadhel

XLDnaute Impliqué
Bonjour à tous,

Vaut mieux joindre un fichier!

Code:
Sub ajouter()
ActiveSheet.Unprotect "MotDePasse"
If Application.IsNA(Range("N7").Value) Then
MsgBox ("Veuillez sélectionner des caractéristiques valides !")
Exit Sub
End If
If Range("N7") = "Indisponible" Then
MsgBox ("Les caractéristiques sélectionnées ne correspondent à aucun disjoncteur !")
Exit Sub
End If
If Range("D4") <> "" And Range("D7") <> "" And Range("F7") <> "" And Range("H7") <> "" And Range("J7") <> "" _
And Range("L7") <> "" And Range("N7") <> "Indisponible" Then
Range("D4").Copy
Sheets("Choix").Range("S" & Range("S" & Rows.Count).End(xlUp).Row + 1).PasteSpecial _
Paste:=xlPasteValues
'// Sélection multiple et collage unique
Range("D7,F7,H7,J7,L7,N7").Copy
Sheets("Choix").Range("T" & Range("S" & Rows.Count).End(xlUp).Row + 0).PasteSpecial _
Paste:=xlPasteValues
Else
MsgBox ("Veuillez sélectionner des caractéristiques valides !")
End If
ActiveSheet.Protect "MotDePasse"
End Sub
 

Discussions similaires

Les cookies sont requis pour utiliser ce site. Vous devez les accepter pour continuer à utiliser le site. En savoir plus…