VBA, copier une plage de cellules fusionnées vers une cellule de destination variable

frangil

XLDnaute Nouveau
Bonjour le forum,

J'ai 2 plages de cellules fusionnées que j'ai nommées dans le fichier ci-joint (Plage 1 et plage 2) que je souhaiterais copier avec le format (fond en couleurs) vers une cellule de destination de n'importe quel fichier ouvert et que je pourrais utiliser avec un bouton utilisable depuis le ruban, comme par exemple "Plage1" pour la 1ère sélection et "Plage2" pour la 2ème sélection.

Merci mille fois et belle journée !

Moscargot
 

Pièces jointes

  • CopiePlagesCellules.xlsm
    8.4 KB · Affichages: 27

job75

XLDnaute Barbatruc
Re : VBA, copier une plage de cellules fusionnées vers une cellule de destination var

Bonjour frangil,

Voyez le fichier joint.

Dans ThisWorkbook :

Code:
Private Sub Workbook_Open()
With Application.CommandBars.Add(Name:="MaBarre")
  .Visible = True
  With .Controls.Add(Type:=msoControlButton)
    .Style = msoButtonCaption
    .OnAction = "Plage1"
    .Caption = "Plage 1"
  End With
  With .Controls.Add(Type:=msoControlButton)
    .Style = msoButtonCaption
    .OnAction = "Plage2"
    .Caption = "Plage 2"
  End With
End With
End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
On Error Resume Next 'si l'on a supprimé la barre
Application.CommandBars("MaBarre").Delete
End Sub
Dans Module1 :

Code:
Sub Plage1()
On Error Resume Next
With Feuil1.[A1:D12]
  If Intersect(ActiveCell, Union(.Cells, Feuil1.[A15:C34])) Is Nothing Then
    ActiveCell.Resize(.Rows.Count, .Columns.Count).UnMerge
    .Copy ActiveCell
  Else
    MsgBox "La cellule active ne doit pas être dans une des plages !", 48
  End If
End With
End Sub

Sub Plage2()
On Error Resume Next
With Feuil1.[A15:C34]
  If Intersect(ActiveCell, Union(.Cells, Feuil1.[A1:D12])) Is Nothing Then
    ActiveCell.Resize(.Rows.Count, .Columns.Count).UnMerge
    .Copy ActiveCell
  Else
    MsgBox "La cellule active ne doit pas être dans une des plages !", 48
  End If
End With
End Sub
Les boutons "Plage 1 et "Plage 2" sont dans l'onglet "COMPLÉMENTS".

Edit : On Error Resume Next est nécessaire dans les macros Plage1 et Plage2.

A+
 

Pièces jointes

  • CopiePlagesCellules(1).xlsm
    19.3 KB · Affichages: 31
Dernière édition:

job75

XLDnaute Barbatruc
Re : VBA, copier une plage de cellules fusionnées vers une cellule de destination var

Re,

Avec le fichier précédent, s'il y a plusieurs fichiers ouverts, l'onglet "COMPLÉMENTS" reste présent si l'on ferme d'abord le fichier des plages.

La solution est de supprimer la barre personnalisée MaBarre sur chaque fenêtre de chaque fichier :

Code:
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Dim wb As Workbook, win As Window
Application.ScreenUpdating = False
On Error Resume Next
For Each wb In Workbooks
  For Each win In wb.Windows
    win.Activate
    Application.CommandBars("MaBarre").Delete
  Next
Next
End Sub
Fichier (2).

A+
 

Pièces jointes

  • CopiePlagesCellules(2).xlsm
    20.5 KB · Affichages: 24

job75

XLDnaute Barbatruc
Re : VBA, copier une plage de cellules fusionnées vers une cellule de destination var

Re,

Ah vraiment, mieux c'est pas possible !

Si car il y a plus simple :

Code:
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Dim win As Window
Application.ScreenUpdating = False
On Error Resume Next
For Each win In Application.Windows
  win.Activate
  Application.CommandBars("MaBarre").Delete
Next
End Sub
Fichier (3).

A+
 

Pièces jointes

  • CopiePlagesCellules(3).xlsm
    26.1 KB · Affichages: 28

frangil

XLDnaute Nouveau
Re : VBA, copier une plage de cellules fusionnées vers une cellule de destination var

Désolé pour le retard, mais coucou me revoilou pour vous remercier et vous demander si c'est possible de "raccrocher" ces 2 macros et une barre que j'ai réussi à créer avec diverses petites macros pratiques de mise en page, impression, ... qui s'appelle "Mo Utilities" ?

Une belle journée et encore M E R C I !

Moscargot
 

Discussions similaires

Statistiques des forums

Discussions
311 737
Messages
2 082 030
Membres
101 876
dernier inscrit
JULIEN21370