Macro pour copier/coller une sélection variable de cellules...

C

Christian0258

XLDnaute Accro
Bonjour à tout le forum,

Je souhaiterais votre aide à l'adaptation d'une macro, afin de copier/coller une sélection (variable) de cellules..

voir fichier joint

Merci pour votre aide si précieuse.

Bien amicalement,
Christian
 

Pièces jointes

  • CopierColler une sélection de cellules.xlsm
    38 KB · Affichages: 72
Trier par date Trier par votes
job75

job75

XLDnaute Barbatruc
Bonjour Christian,

Le code de la feuille "LesCA" :
Code: 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Areas.Count > 1 Or Target.Row > 1 Or Target.Column = 1 Or Target.Rows.Count <> 5 Or Target(1) = "" Then Exit Sub
With Feuil3.Range("D" & Feuil3.Rows.Count).End(xlUp)(2, 2).Resize(5, Target.Columns.Count)
  Target.Copy .Cells
  .Cells = .Cells.Value 'supprime les formules
  .Cells(5, 1).Copy .Cells(5, 0) 'pour copier les formats
  .Cells(5, 0) = "=IF(RC[1]="""","""",SUM(" & .Rows(5).Address(0, 0, xlR1C1, , .Cells(5, 0)) & "))"
  .Cells(5, 0).Borders.Weight = xlThin
  .Borders(xlEdgeLeft).Weight = xlThin 'c'est mieux
  .Borders(xlEdgeRight).Weight = xlThin 'c'est mieux
  .Parent.Activate 'facultatif
End With
End Sub
Pour commencer à tester supprimer d'abord tout ce qui est sous la ligne 9 de la feuille "RécapCA".

Nota : pas trop compris l'intérêt du test SI(E14="";""; dans la formule en D14...

A+
 
Vote positif 0 Vote négatif
C

Christian0258

XLDnaute Accro
Re, le forum,
Bonjour à tous,

Je reviens vers vous, pour le code que m'a concocté job75.
Serait-il possible que lors de la sélection des CA, dans la feuille "LesCA", la zone ainsi sélectionnée soit encadrée d'une bordure rouge.
Ces encadrements permettraient de bien visualiser les CA déjà sélectionnés et un contrôle de cohérence des sélections ainsi effectuées.

Merci pour votre aide.
Bien à vous,
Christian
 
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Bonsoir Christian,

Bon, mais ça pollue grave le tableau source :
Code: 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Areas.Count > 1 Or Target.Row > 1 Or Target.Column = 1 Or Target.Rows.Count <> 5 Or Target(1) = "" Then Exit Sub
Dim i As Byte
With Feuil3.Range("D" & Feuil3.Rows.Count).End(xlUp)(2, 2).Resize(5, Target.Columns.Count)
  Target.Copy .Cells
  .Cells = .Cells.Value 'supprime les formules
  .Cells(5, 1).Copy .Cells(5, 0) 'pour copier les formats
  .Cells(5, 0) = "=IF(RC[1]="""","""",SUM(" & .Rows(5).Address(0, 0, xlR1C1, , .Cells(5, 0)) & "))"
  .Cells(5, 0).Borders.Weight = xlThin
  .Borders(7).Weight = xlThin 'c'est mieux
  .Borders(10).Weight = xlThin 'c'est mieux
  .Parent.Activate 'facultatif
End With
For i = 7 To 10
  Target.Borders(i).Weight = xlThick
  Target.Borders(i).Color = vbRed
Next
End Sub
Bonne fin de soirée.

Edit : petite erreur (mais VBA n'est pas logique), c'est .Borders(10) qu'il faut écrire.
 
Dernière édition:
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Re,

Il vaut mieux ceci, c'est plus facile à effacer ensuite :
Code: 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Areas.Count > 1 Or Target.Row > 1 Or Target.Column = 1 Or Target.Rows.Count <> 5 Or Target(1) = "" Then Exit Sub
With Feuil3.Range("D" & Feuil3.Rows.Count).End(xlUp)(2, 2).Resize(5, Target.Columns.Count)
  Target.Copy .Cells
  .Cells = .Cells.Value 'supprime les formules
  .Cells(5, 1).Copy .Cells(5, 0) 'pour copier les formats
  .Cells(5, 0) = "=IF(RC[1]="""","""",SUM(" & .Rows(5).Address(0, 0, xlR1C1, , .Cells(5, 0)) & "))"
  .Cells(5, 0).Borders.Weight = xlThin
  .Borders(7).Weight = xlThin 'c'est mieux
  .Borders(10).Weight = xlThin 'c'est mieux
  .Parent.Activate 'facultatif
End With
Target.Interior.ColorIndex = 15 'gris
End Sub
Edit : petite erreur (mais VBA n'est pas logique), c'est .Borders(10) qu'il faut écrire.

A+
 
Dernière édition:
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Bonjour Christian,

J'ai complété ton fichier, j'espère que ça t'intéressera.

Le code de la feuille "RécapCA" :
Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
Feuil2.Worksheet_BeforeDoubleClick Feuil2.[A5], False 'lance la macro (qui n'est pas Private)
End Sub
Le code modifié de la feuille "LesCA" :
Code: 
Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) 'n'est plus Private...
If Target.Address <> "$A$5" Then Exit Sub
Cancel = True: _
Application.ScreenUpdating = False
Feuil3.UsedRange.Name = "RécapCA" 'nom défini dans le classeur
With [B5].Resize(2, Cells(2, Columns.Count).End(xlToLeft).Column)
  .Rows(1) = "=IF(COUNTA(B3:B4),COUNTA(B3:B4)/2,"""")" 'ligne 5
  .Rows(2) = "=1/COUNTIF(RécapCA,B2)" 'ligne 6 (auxiliaire)
  With .Rows(-3).Resize(5) 'lignes 1:5
    .Interior.ColorIndex = xlNone 'effacement des couleurs de fond
    On Error Resume Next 's'il n'y a pas de dates en Feuil3
    Intersect(.Cells, .Rows(6).SpecialCells(xlCellTypeFormulas, 1).EntireColumn).Interior.Color = 14540253 'gris clair
    .Rows(6) = "" 'RAZ ligne 6
  End With
End With
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Areas.Count > 1 Or Target.Row > 1 Or Target.Column = 1 Or Target.Rows.Count <> 5 Or Target(1) = "" Then Exit Sub
Application.EnableEvents = False 'évite de lancer la Worksheet_Change et la Worksheet_BeforeDoubleClick
With Feuil3.Range("D" & Feuil3.Rows.Count).End(xlUp)(2, 2).Resize(5, Target.Columns.Count)
  Target.Copy .Cells
  .Cells = .Cells.Value 'supprime les formules
  .Cells(5, 1).Copy .Cells(5, 0) 'pour copier les formats
  .Cells(5, 0) = "=IF(RC[1]="""","""",SUM(" & .Rows(5).Address(0, 0, xlR1C1, , .Cells(5, 0)) & "))"
  .Cells(5, 0).Borders.Weight = xlThin
  .Borders(xlEdgeLeft).Weight = xlThin 'c'est mieux
  .Borders(xlEdgeRight).Weight = xlThin 'c'est mieux
  .Parent.Activate 'facultatif
End With
Target.Interior.Color = 14540253 'gris clair
Application.EnableEvents = True
End Sub
Fichier joint.

A+
 

Pièces jointes

  • CopierColler une sélection de cellules(1).xlsm
    51.8 KB · Affichages: 45
Dernière édition:
Vote positif 0 Vote négatif

Discussions similaires

Sellig
  • Résolu(e)
XL 2019 Sélection zone avec la souris et copier puis Sélection zone avec la souris et coller
Réponses
9
Affichages
433
Sellig
Sellig
A
  • Question
XL 2021 Macro copier dans un fichier Excel sur Sharepoint
Réponses
1
Affichages
114
vgendron
vgendron
A
  • Question
XL 2019 Copier le contenu d'un MsgBox ou d'une variable
Réponses
12
Affichages
299
Attila451
A
V
  • Question
XL pour MAC outil coller le contenu du presse papier
Réponses
2
Affichages
443
Valter
V
P
  • Question
Microsoft 365 lancer une macro excel tous les jour sans ouvrir le fichier
Réponses
6
Affichages
862
patricktoulon
patricktoulon
C
  • Question
Microsoft 365 Formule pour remplacer des cellules vides
Réponses
3
Affichages
170
JHA
J
E
  • Question
Microsoft 365 Couleurs de fichiers qui changent
Réponses
1
Affichages
206
mapomme
mapomme
K
  • Question
XL 2010 copier des dossiers ou fichiers pour les coller dans un disque dur externe
Réponses
2
Affichages
346
kiki29
kiki29
M
  • Question
XL 2016 macro copier coller de plusieurs feuilles excel
Réponses
2
Affichages
348
klin89
klin89
V
  • Question
Microsoft 365 Nom variable dans Macro
Réponses
2
Affichages
182
VieuxSeb
V

Membres actuellement en ligne

10 membres et 137 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
314 173
Messages
2 106 831
Membres
109 692
dernier inscrit
renergy971