|
Cette macro permet de faire une copie de zone multiple et de la placer sur un autre endroit... Deux options se rajoutent dans le menu clic droit de la souris "Copier zones multiples" et "Coller zones multiples" pour le mode d'emploi, voir en fin de page... Attention !...une partie de la procédure est à copier dans Thisworboock et l'autre dans un module...
'************************************
'partie à coller dans ThisWorkbook
'************************************
'
'Ti 13-01-03 xlti@wanadoo.fr
'
Option Explicit
Private Sub Workbook_Open()
Initialise
End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
SupprimeControles
End Sub
Private Sub Workbook_Activate()
'à activer si on utilise l'événement Deactivate ci-dessous
'Initialise
End Sub
Private Sub Workbook_Deactivate()
'si on veut interdire la copie multiple dans d'autres classeurs ouverts
'SupprimeControles
End Sub
'
'************************************
'partie à coller dans un module
'************************************
'
'Ti 13-01-03 xlti@wanadoo.fr
'
Option Explicit
Option Private Module
Const MyTag As String = "MnsTi"
Dim Plages() As Range
Private Function Ajuste(PlageSource As Range, CelRefDest As Range, _
ligneRef As Long, ColRef As Long)
'cette fonction ajuste la plage à copier Plagesource et renvoie la cellule de
'destination de la copie
Dim Ligne1 As Long, Col1 As Long, LigneFin As Long, ColFin As Long
Dim DecalLigne As Long, DecalCol As Long
Dim CelTemp As Range, Decalage As Long
With PlageSource
DecalLigne = .Cells(1, 1).Row - ligneRef
DecalCol = .Cells(1, 1).Column - ColRef
End With
With CelRefDest
Ligne1 = .Cells(1, 1).Row + DecalLigne
Col1 = .Cells(1, 1).Column + DecalCol
LigneFin = Ligne1 + PlageSource.Rows.Count - 1
ColFin = Col1 + PlageSource.Columns.Count - 1
If LigneFin >= 1 And ColFin >= 1 Then
'si ça déborde
If Ligne1 < 1 Then
'on ajuste la ligne de la plage à copier
Decalage = 1 - Ligne1
Set PlageSource = PlageSource.Offset(Decalage, 0).Resize _
(RowSize:=PlageSource.Rows.Count - Decalage)
'et on met la ligne de destination à 1
Ligne1 = 1
End If
If Col1 < 1 Then
'on ajuste la colonne de la plage à copier
Decalage = 1 - Col1
Set PlageSource = PlageSource.Offset(0, Decalage).Resize _
(columnsize:=PlageSource.Columns.Count - Decalage)
'et on met la colonne de destination à 1
Col1 = 1
End If
With .Worksheet
Set Ajuste = .Range(.Cells(Ligne1, Col1), .Cells(LigneFin, ColFin))
End With
Else
'si la plage est entièrement cachée, on ne renvoie rien
Set Ajuste = Nothing
End If
End With
'je n'ai pas pris en compte les cas où ça déborderait en bas et à droite !
End Function
Sub CollageNonContigu()
Dim Boucle As Byte, CelSelect As Range
Dim CelTemp As Range, CelCopie As Range, Ligne1 As Long, Col1 As Long
Dim DecalLigne As Long, DecalCol As Long
If UBound(Plages) = 0 Then Exit Sub
On Error GoTo erreur
Set CelSelect = Selection
'la première ligne
Ligne1 = Plages(1).Cells(1, 1).Row
Col1 = Plages(1).Cells(1, 1).Column
For Boucle = 1 To UBound(Plages)
If Boucle = 1 Then
Plages(1).Copy CelSelect
Else
With Plages(Boucle)
'comme cette plage peut être modifiée par Ajuste, on la duplique
Set CelTemp = Plages(Boucle)
Set CelCopie = Ajuste(CelTemp, CelSelect, Ligne1, Col1)
If Not CelCopie Is Nothing Then CelTemp.Copy CelCopie
End With
End If
Next Boucle
Exit Sub
erreur:
MsgBox "Erreur au collage des zones multiples"
End Sub
Sub CopieNonContigu()
Dim Boucle As Byte, NbPlages As Byte
NbPlages = Selection.Areas.Count
If NbPlages <= 1 Then
ReDim Plages(0)
AutoriseCollage False
Exit Sub
End If
ReDim Plages(1 To NbPlages)
For Boucle = 1 To NbPlages
Set Plages(Boucle) = Selection.Areas(Boucle)
Next Boucle
AutoriseCollage True
End Sub
Sub Initialise()
Dim LBar As CommandBar, Ctrl As CommandBarControl
On Error GoTo erreur
SupprimeControles
Set LBar = Application.CommandBars("cell")
With LBar.Controls _
.Add(Type:=msoControlButton, before:=1, temporary:=True)
.Caption = "Copier zones multiples"
.OnAction = "CopieNonContigu"
.Tag = MyTag
End With
With LBar.Controls _
.Add(Type:=msoControlButton, before:=2, temporary:=True)
.Caption = "Coller zones multiples"
.OnAction = "CollageNonContigu"
.Tag = MyTag
.Enabled = False
End With
Exit Sub
erreur:
MsgBox "Impossible d'initialiser la fonction ""Copie de zones non contigües"""
SupprimeControles
End Sub
Private Sub AutoriseCollage(Autorise As Boolean)
Dim LBar As CommandBar, Ctrl As CommandBarControl
On Error Resume Next
Set LBar = Application.CommandBars("cell")
With LBar.Controls(2)
.Enabled = Autorise
End With
End Sub
Sub SupprimeControles()
Dim Ctrl As CommandBarControl
ReDim Plages(0)
On Error Resume Next
For Each Ctrl In Application.CommandBars("cell").Controls
If Ctrl.Tag = MyTag Then Ctrl.Delete
Next Ctrl
End Sub
Mode d'emploi : 1. sélectionner les zones à copier (attention, l'ordre compte, la première zone sélectionnée détermine la position respective des zones suivantes lors du collage, voir l'illustration) tout en maintenant la touche Ctrl appuyée - Click droit - Copier zones multiples 2. sélectionner la cellule de destination - Click droit - Coller zones multiples Cas de Figure 1 : 
Cas de figure 2 : 
Date de création : 24/05/2005 - 18:57
Dernière modification : 25/05/2005 - 22:43
Catégorie : Feuille
Page lue 465 fois
 Prévisualiser la page
 Imprimer la page
|
|
OOo
OOo
Membres: 1661
Membre en ligne: 0
Anonymes en ligne: 29
Haut 
