Acquisition d'une plage de cellule dynamique
Bonjour ,
Je joins un fichier excel pour illustrer mon besoin.
Je constitue un fichier de devis pour une société (on va dire que c'est une société de wagons
Dans les lignes 4 à 16, je mes les références des wagons que mon client veut me commander.
Par exemple, dans l'exemple que j'ai complété, mon client me demandera 2 références de wagons, donc j'ai complété les lignes 4 et 5.
S'il m'en avait demandé 5, j'aurais complété les lignes 4,5,6,7,8...etc
La ligne total vient effectuer des opérations de somme...etc sur mes différents produits.
J'aimerais pouvoir réaliser l'acquisition d'un tableau récapitulant chaque ligne que j'ai complétée plus la ligne total.
J'ai déjà placé sur mon fichier la ligne 20 qui est la copie de ma ligne 2.
J'aimerais dans ce contexte qu'en dessous viennent se mettre les lignes 4,5 et 17.
Mais si mon client m'avait demandé 5 références de wagon, j'aurais aimé pouvoir récupérer en dessous les lignes 4 5 6 7 8 et 17.
Sauriez-vous m'aider avec mon problème ?
Bonne journée à tous
Bonjour,
Je ne vois pas trop l’intérêt il y a des outil comme des filtres (Données/ filtrer) qui feront très bien le taf et largement suffisant (d'après votre descriptif).
bonne continuation
Bonjour
Sinon
Code Module associé au bouton en A2
Sub Action()
Range("B4:P17").Copy
Range("B21").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.ScreenUpdating = False
Range("B21:B34").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
Range("B21").Select
End Sub
Cordialement
Bonjour
Sinon
Code Module associé au bouton en A2
Sub Action() Range("B4:P17").Copy Range("B21").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Application.ScreenUpdating = False Range("B21:B34").SpecialCells(xlCellTypeBlanks).EntireRow.Delete Range("B21").Select End Sub
Cordialement
Merci beaucoup Amadeus !
Je l'ai réadapté à mon fichier original.
Petite question cependant: est il possible de garder la mise en forme des cellules que j'ai copiées ?
Par exemple, mes NON sur mon fichier original sont définis pour s'afficher en rouge sur une case à fond rose.
En appliquant la formule, je retrouve le contenu de la cellule sans la mise en forme
En tout cas merci pour ce code qui marche nickel !
Bonjour
Tu ajoutes l'instruction pour les formats
Sub Action()
Range("B4:P17").Copy
Range("B21").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.ScreenUpdating = False
Range("B21:B34").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
Range("B21").Select
End Sub
ou, plus condensé
Sub Action()
Range("B4:P17").Copy
Range("B21").Select
With Selection
.PasteSpecial Paste:=xlPasteValues
.PasteSpecial Paste:=xlPasteFormats
End With
Application.ScreenUpdating = False
Range("B21:B34").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
Range("B21").Select
End Sub
Cordialement
Bonjour
Tu ajoutes l'instruction pour les formats
Sub Action() Range("B4:P17").Copy Range("B21").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _ SkipBlanks:=False, Transpose:=False Application.ScreenUpdating = False Range("B21:B34").SpecialCells(xlCellTypeBlanks).EntireRow.Delete Range("B21").Select End Sub
ou, plus condensé
Sub Action() Range("B4:P17").Copy Range("B21").Select With Selection .PasteSpecial Paste:=xlPasteValues .PasteSpecial Paste:=xlPasteFormats End With Application.ScreenUpdating = False Range("B21:B34").SpecialCells(xlCellTypeBlanks).EntireRow.Delete Range("B21").Select End Sub
Cordialement
Merci... je rêverais d'être bon en VBA.
Dernière petite question, en réadaptant le code à mon fichier original, j'ai une erreur 1004 (application ou objet qui s'affiche).
Le code marche cependant quand même mais j'ai ce message d'erreur qui s'affiche à chaque fois. Est ce dû à ce que j'ai écrit ?:
Sub Action()
Range("A13:AC43").Copy
Range("A46").Select
With Selection
.PasteSpecial Paste:=xlPasteValues
.PasteSpecial Paste:=xlPasteFormats
End With
Application.ScreenUpdating = False
Range("A46:B76").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
Range("A46").Select
End Sub
Jai trouvé moi même il fallait que je mette B77 !
Merci pour tout !
Bonjour
Chez moi, le code marche parfaitement sur le fichier téléchargé.
Ton fichier est-il différent?
Cordialement
Edit: tu as posté pendant que je contrôlais sur le fichier.
Bonjour
Chez moi, le code marche parfaitement sur le fichier téléchargé.
Ton fichier est-il différent?
Cordialement
Edit: tu as posté pendant que je contrôlais sur le fichier.
Oui j'avais simplifié le fichier que j'avais mis en ligne car mon fichier principal est...très chargé
Tout marche parfaitement maintenant !
J'avais fait une erreur en réadaptant le code !
Merci encore
Bonjour
Chez moi, le code marche parfaitement sur le fichier téléchargé.
Ton fichier est-il différent?
Cordialement
Edit: tu as posté pendant que je contrôlais sur le fichier.
Je me permets de poster une dernière question relative au topic.
Dans mon document original, j'avais un tableau à la droite de celui que j'ai envoyé qui était assez complet.
Lorsque j'applique la formule, ce tableau se fait couper un certain nombre de lignes, car pour que les lignes qui nous intéressent soient collées, on a effacé des lignes entières dont certaines cellules étaient renseignées.
Est il possible d'effacer dans la formule seulement les lignes "blank" correspondant à la plage de colonnes de mon tableau original ?
Par exemple, en ce moment si je complète les lignes 4 et 5, lorsque la macro copie colle, elle va supprimer toutes les lignes qui ne sont pas 4 5 ou 17 pour garder à la suite 4 5 17.
Mon souhaite serait que au lieu d'effacer les lignes 6 à 16, elle efface de B6 à P6 ... B16 à P16 pour qu'à la fin, le résultat soit le même, mais que mes tableaux situés plus loin dans mon fichier original ne soient pas coupés ?
J'imagine la solution est en rapport avec le fait qu'actuellement on demande à la routine d'effacer les lignes entières correspondant aux cases vides.
Bonjour
J'ai travaillé sur l'ancien fichier, tu modifieras.
Sub Action()
Dim Cel As Range
For Each Cel In Range("B4:B17")
If Cel <> "" Then
Range(Cel, Cel.Offset(0, 14)).Copy
If Range("B21") = "" Then
Range("B21").Select
ElseIf Range("B21") <> "" Then
Range("B20").End(xlDown).Offset(1, 0).Select
End If
With Selection
.PasteSpecial Paste:=xlPasteValues
.PasteSpecial Paste:=xlPasteFormats
End With
End If
Next Cel
Application.CutCopyMode = False
Range("B20").Select
End Sub
Cordialement
Salut Amadeus,
Merci encore une fois pour ton aide.
Je ne suis pas sûr de tout comprendre ce coup ci.
J'ai fait un test sur le fichier que tu m'as renvoyé en remplissant 4 désignations (de B4 à B7).
J'ai aussi rajouté des 5 de R22 à R30 pour voir si ces 5 disparaitront lors de l'activitation de la macro.
Lorsque j'active la macro, j'obtiens l'image que je te fait parvenir en PJ.
Je ten joins une seconde qui montre ce que je souhaiterais (au cas où je me serais mal expliqué).
On voit que les 5 sont toujours là sans avoir disparu tandis que les lignes se sont bien copiées comme souhaité.
Je m'excuse une nouvelle fois du dérangement !
Amodu1244
Bonjour
Il est probable pour obtenir ce résultat que tu as cliqué plusieurs fois sur le bouton associé à la macro.
Pour éviter ce risque, je te suggères d'effacer tout ce qui a été copié précédemment avant de coller les nouvelles valeurs.
Avec cette instruction en début de Code
Range("B21:P34").Clear
Le Code complet
Sub Action()
Dim Cel As Range
Range("B21:P34").Clear
For Each Cel In Range("B4:B17")
If Cel <> "" Then
Range(Cel, Cel.Offset(0, 14)).Copy
If Range("B21") = "" Then
Range("B21").Select
ElseIf Range("B21") <> "" Then
Range("B20").End(xlDown).Offset(1, 0).Select
End If
With Selection
.PasteSpecial Paste:=xlPasteValues
.PasteSpecial Paste:=xlPasteFormats
End With
End If
Next Cel
Application.CutCopyMode = False
Range("B20").Select
End Sub
Le fichier joint avec ce code
Cordialement
Merci une nouvelle fois !
Je n'ai plus rien à demander