XL 2013 VBA création d'un bouton copier/coller des lignes préalablement

[@lex16]

Bonjour à vous tous et merci d'avance pour vos réponses.


Débutant en VBA

Je voudrais à l'aide d'un bouton copier/coller le texte des lignes sélectionnées et les coller dans la feuille 2.

J'ai déjà programmé les cases à cocher avec un surlignage visuelle.

le fichier joint est juste une représentation.


Merci de votre aide .

 

[soan]

Bonjour Alex,

2ème feuille : entièrement vide ; va sur la 1ère feuille ; fais Ctrl e
Fais d'autres tests en cochant ou décochant d'autres lignes.

Regarde d'abord le code VBA de Module1.
Ensuite, regarde aussi celui de Feuil1.

Si tout est OK, merci de cliquer sur « Marquer comme solution ».
Sinon, tu peux demander une adaptation.

soan

 

[job75]

Bonjour @lex16, soan, le forum,

J'ai renseigné la propriété LinkedCell des CheckBoxes ce qui permet d'utiliser cette macro :

Sub Copie()
With Feuil2 'CodeName de la feuille
    Feuil1.Cells.Copy .Cells(1)
    .Cells(1).Copy .Cells(1) 'allège la mémoire
    .Columns(7).Replace False, "#N/A"
    On Error Resume Next 'si aucune SpecialCell
    .Columns(7).SpecialCells(xlCellTypeConstants, 16).EntireRow.Delete
    .Columns(7).Resize(, 2).Delete 'supprime aussi le bouton
    .Activate
End With
End Sub

Notez que tout est copié, y compris les hauteurs des lignes et largeurs des colonnes.

Bon week-end.

 

[@lex16]

bonjour Soan,
un grand merci à toi,
Pourrais tu me dire quoi modifier pour partir de la 6iéme ligne et aussi pour modifier la page de destination et les coller à la suite.
un grand merci d'avance
cordialement

 

[job75]

Moi c'est job75

Pourrais tu me dire quoi modifier pour partir de la 6iéme ligne

Avec mon code il suffit de supprimer les lignes 1 à 5 après le copier-coller :

Sub Copie()
With Feuil2 'CodeName de la feuille
    Feuil1.Cells.Copy .Cells(1)
    .Cells(1).Copy .Cells(1) 'allège la mémoire
    .Rows("1:5").Delete
    .Columns(7).Replace False, "#N/A"
    On Error Resume Next 'si aucune SpecialCell
    .Columns(7).SpecialCells(xlCellTypeConstants, 16).EntireRow.Delete
    .Columns(7).Resize(, 2).Delete 'supprime aussi le bouton
    .Activate
End With
End Sub

 

[soan]

Bonjour Alex, job75,

Rebelotte. Feuil2 : vide ; va sur Feuil 1 ; coche et décoche les cases,
mais n'appuie pas encore sur le bouton "COPIER" (ni Ctrl e).

-----------------------------------------------------------------------------------

Pour partir de la 6ème ligne, j'ai inséré 5 lignes au-dessus de la 1ère ➯
la ligne avec "d6" et "f6" est en ligne 6 ; idem en dessous, jusque :
la ligne avec "d9" et "f9" est en ligne 9.

Dans le code de Feuil1, j'ai modifié le 1er paramètre des appels à Job() :

If CheckBox1 Then Job 6, 0 Else Job 6, -1
If CheckBox2 Then Job 7, 32 Else Job 7, -1
If CheckBox3 Then Job 8, 64 Else Job 8, -1
If CheckBox4 Then Job 9, 96 Else Job 9, -1

La sub Job() est restée inchangée.

Code VBA complet :

Option Explicit

Private Sub Job(lig As Byte, G%)
  With Cells(lig, 1).Resize(, 6).Interior
    If G >= 0 Then .Color = RGB(255, G, 0) Else .ColorIndex = -4142
  End With
End Sub

Private Sub CheckBox1_Click()
  If CheckBox1 Then Job 6, 0 Else Job 6, -1
End Sub

Private Sub CheckBox2_Click()
  If CheckBox2 Then Job 7, 32 Else Job 7, -1
End Sub

Private Sub CheckBox3_Click()
  If CheckBox3 Then Job 8, 64 Else Job 8, -1
End Sub

Private Sub CheckBox4_Click()
  If CheckBox4 Then Job 9, 96 Else Job 9, -1
End Sub

-----------------------------------------------------------------------------------

Pour coller les destinations à la suite (donc les unes sous les autres),
j'ai changé lig en lg1 et ajouté lg2 ; 4 lignes de code modifiées :

Dim coche As Shape, lg1&, lg2&
.Cells.Clear: lg2 = 1
lg1 = coche.TopLeftCell.Row: Cells(lg1, 1).Resize(, 6).Copy
.Cells(lg2, 1).PasteSpecial -4163: lg2 = lg2 + 1

Code VBA complet :

Option Explicit

Sub CpyLigs()
  If ActiveSheet.Name <> "Feuil1" Then Exit Sub
  Dim coche As Shape, lg1&, lg2&: Application.ScreenUpdating = 0
  With Worksheets(2)
    .Cells.Clear: lg2 = 1
    For Each coche In ActiveSheet.Shapes
      If coche.Name Like "Check*" Then
        If ActiveSheet.OLEObjects(coche.Name).Object.Value Then
          lg1 = coche.TopLeftCell.Row: Cells(lg1, 1).Resize(, 6).Copy
          .Cells(lg2, 1).PasteSpecial -4163: lg2 = lg2 + 1
        End If
      End If
    Next coche
    Application.CutCopyMode = 0: .Select: [A1].Select
  End With
End Sub

Fais Ctrl e, puis regarde le résultat obtenu.

soan

 

[@lex16]

bonjour Soan, job75,
un grand merci à vous, j'ai compris le fonctionnement du copier coller dans une autre feuille avec le décalage colonne et ligne.
Et maintenant j'essaye de copier coller les valeurs dans un tableau.

Pourriez-vous me dire quoi modifier pour copier dans le tableau à partir de la ligne 6
un grand merci d'avance
dans le fichier j'ai mis la matrice du tableau vide, il faut commencer ligne 6 colonnes A:K
cordialement

 

[soan]

Pour @lex16

Je ne t'ai pas laissé tomber : je travaille sur ton fichier,
mais il y a encore beaucoup de choses !

Je posterai le nouveau fichier quand j'aurai fini.

soan

 

[soan]

Bonjour Alex,

Sur la feuille "mm", je n'ai rien changé, et tu peux voir que les 4 cases à cocher
sont toujours cochées ; ne clique pas sur le bouton COPIER (ni Ctrl e), et va sur
"Feuil2" ; tu peux voir que le tableau des résultats est vide, et note bien que la
cellule active est K19 ; reste sur cette feuille, et fais Ctrl e : ça remplit le tableau
correctement et la cellule active est toujours K19 ; tu comprendras l'intérêt de
cette remarque quand tu liras les commentaires du code VBA (texte en vert).

Si tu avais été sur la feuille "mm" pour cliquer sur le bouton COPIER (ou Ctrl e),
le résultat de la macro aurait été exactement le même ; tu as donc le choix de
la manip, selon ta préférence du moment.

Je n'ai pas parlé de la feuille "555" car j'ai compris qu'elle te sert juste pour
montrer les résultats attendus (tu aurais pu le préciser dans ton post #7, et
indiquer aussi que tu veux copier les valeurs de "mm" sur "Feuil2").

Fais Alt F11 pour voir le nouveau code VBA, et lis bien tous les commentaires.

Si tout est OK, merci de cliquer sur « Marquer comme solution ».
Sinon, tu peux demander une autre adaptation.

À te lire pour avoir ton avis.

soan

 

[job75]

Bonjour @lex16, soan,

S'il faut copier uniquement les valeurs une méthode classique est d'utiliser un tableau VBA :

Sub Copie()
Dim ncol%, tablo, i&, n&, j%
ncol = 12
tablo = Feuil1.[A6].CurrentRegion.Resize(, ncol) 'matrice, plus rapide
For i = 1 To UBound(tablo)
    If tablo(i, ncol) Then 'si VRAI (CheckBox cochée)
        n = n + 1
        For j = 1 To ncol - 1
            tablo(n, j) = tablo(i, j)
        Next j
    End If
Next
'---restitution---
With Feuil2.[A6] '1ère cellule de destination, à adapter
    If n Then .Resize(n, ncol - 1) = tablo
    .Offset(n).Resize(Rows.Count - n - .Row + 1, ncol - 1).ClearContents 'RAZ en dessous
    .Parent.Activate
End With
End Sub

L'exécution est très rapide, la 12ème colonne (L) est celle des cellules liées.

A+

 

[@lex16]

Bonjour Soan et Job75

merci beaucoup pour les solutions apportés.
merci Soan pour toutes les explications que tu m'as écrit dans le code et les très bons conseils.

 

[soan]

Bonsoir Alex,

Je mets ci-dessous le code VBA du fichier de mon
post #9, sans tous les longs commentaires :

Option Explicit

Sub CpyLigs()
  Dim coche As Shape, cel As Range, lg1&, lg2&: Application.ScreenUpdating = 0
  Worksheets("Feuil2").Select: Set cel = ActiveCell
  lg2 = Cells(Rows.Count, 1).End(3).Row
  Range("A6:K" & lg2).ClearContents: lg2 = 6
  With Worksheets("mm")
    For Each coche In .Shapes
      If coche.Name Like "Check*" Then
        If .OLEObjects(coche.Name).Object.Value Then
          lg1 = coche.TopLeftCell.Row: .Cells(lg1, 1).Resize(, 11).Copy
          Cells(lg1, 1).PasteSpecial -4163: lg2 = lg2 + 1
        End If
      End If
    Next coche
    Application.CutCopyMode = 0: cel.Select
  End With
End Sub

(maintenant, Module1 contient seulement 20 lignes)

soan