'### Adapter au nom de la feuille ###
Public Const MA_FEUILLE As String = "Feuil1"
'###################################
Private Plage As Range
Private CB As CommandBar
Private CBB As CommandBarButton
Sub Copier_pmo(Optional dummy As Byte)
Dim R As Range
On Error GoTo Erreur
Set R = Selection.Cells(1, 1)
If R.Column <> 6 And R.Column <> 9 Then Exit Sub
If R = "" Then Exit Sub
Set R = R.Resize(1, 3)
Set Plage = R
R.Copy 'ne sert que pour la visualisation de l'utilisateur
Erreur:
If Err <> 0 Then MsgBox "Erreur " & Err.Number & _
vbCrLf & Err.Description
End Sub
Sub Coller_pmo(Optional dummy As Byte)
Dim R As Range
Dim C As Range
Dim T(1 To 1, 1 To 4)
Dim i&
On Error GoTo Erreur
If Plage Is Nothing Then Exit Sub
Set R = Selection.Cells(1, 1)
If R.Column <> 2 Then Exit Sub
If R <> "" Then Exit Sub
If R.Row = 1 Then Exit Sub
If R.Offset(-1, 0) = "" Then Exit Sub
For Each C In Plage
i& = i& + 1
If i& < 3 Then
T(1, i&) = C
Else
T(1, i& + 1) = C
End If
Next C
Set R = R.Resize(1, 4)
R = T
Set Plage = Nothing
Application.CutCopyMode = False
Erreur:
If Err <> 0 Then MsgBox "Erreur " & Err.Number & _
vbCrLf & Err.Description
End Sub
Sub DelBarre(Optional dummy As Byte)
For Each CB In Application.CommandBars
If CB.Name = "Copier/Coller personnalisés" Then
CB.Delete
Exit For
End If
Next CB
End Sub
Sub AddBarre(Optional dummy As Byte)
Set CB = Application.CommandBars.Add
With CB
.Name = "Copier/Coller personnalisés"
.Visible = True
.Position = msoBarRight
End With
Set CBB = CB.Controls.Add(Type:=msoControlButton, ID:=22, Before:=1)
With CBB
.Caption = "Collage spécial"
.OnAction = "Coller_pmo"
.DescriptionText = "Collage spécial"
End With
Set CBB = CB.Controls.Add(Type:=msoControlButton, ID:=19, Before:=1)
With CBB
.Caption = "Copie spéciale"
.OnAction = "Copier_pmo"
.DescriptionText = "Copie spéciale"
End With
End Sub
serait-ce l'heure tardive et mon neuronne qui faiblit, parce que là, y a un truc.
