Macro interactive pour Copie de cellule

[Chri8Ed]

Bonjour

Je dispose d’une macro qui a été en grande partie été écrite par HASCO
Cette macro me permet de copier une cellule dans un autre emplacement puis une fois cette cellule copiée de remettre la cellule ainsi copiée dans l’état originale (Vidée, Sans commentaire, Couleur violette)

Cette macro fonctionne très bien, mais elle ne fonctionne que pour une seule cellule à la fois et je voudrais pouvoir l’utiliser pour plusieurs cellules (Je précise que ces cellules seraient contigües « ex : A1 :A5 »)

Une évolution de cette macro pour la rendre applicable pour une série de cellules devait être possible, mais je n’arrive pas à trouver la solution.

Sub Cellule_Déplacement_D()

     With Selection
         If .Cells.Count <> 2 Or .Areas.Count <> 2 Then Exit Sub
         .Item(1).Copy
         With .Areas(2)(1)
             .PasteSpecial xlPasteValues
             .PasteSpecial xlPasteFormats
             .PasteSpecial xlPasteComments
         End With
         With .Areas(1)(1)
         .Item(1).ClearContents
         .Comment.Delete
         .Interior.Color = 16751052
         End With
     End With
     Application.CutCopyMode = False
     
End Sub

 

[tototiti2008]

Re : Macro interactive pour Copie de cellule

Re,

Oui, ça complique

Peut-être

Sub Cellule_Déplacement_D()
     Dim PlageSource As Range, PlageDest As Range, Cellule As Range
     With Selection
          If .Areas.Count < 2 Then Exit Sub
          Set PlageSource = .Areas(1)
          Set PlageDest = .Areas(.Areas.Count)(1)
          With PlageDest
            PlageSource.Copy
            .PasteSpecial xlPasteComments
            PlageSource.Copy
            .PasteSpecial xlPasteFormats
            PlageSource.Copy
            .PasteSpecial xlPasteValues
          End With
          For Each Cellule In PlageSource
            If Application.Intersect(Selection, Cellule) Is Nothing Then
                Cellule.ClearContents
                Cellule.ClearComments
                Cellule.Interior.Color = 16751052
            End If
          Next
      End With
      Set PlageSource = Nothing
      Set PlageDest = Nothing
      Application.CutCopyMode = False
 End Sub

 

[Chri8Ed]

Re : Macro interactive pour Copie de cellule

Bonjour Tototiti

Merci beaucoup pour ta macro

Le problème est réglé

J’ai pris un peu de temps avant de répondre
Car je voulais voir si cela fonctionnait parfaitement
Et cela fonctionne bien parfaitement

Merci encore à tous