Copie de cellules non contigües

[Didou59]

Bonjour à toutes et tous,
Absent du forum depuis un moment, je reviens vers vous pour un problème que je n'arrive pas à solutionner malgré mes nombreuses recherches. De plus, je suis loin d'être un expert en VBA.
Je vous expose ma demande, j'ai une feuille "Feuil1" sur laquelle se trouve des listes déroulantes en cascade, des affichages automatisés et des zones de saisie. Je voudrai sélectionner des cellules non contigües telle que G8, C14, J14, E16 etc. et les copier dans une feuille "Feuil2" sur les colonnes A à A+n (nombre de cellules non contigües de la feuille "Feuil1" en ligne 2 et répéter l'opération autant de fois que nécessaire. Je vous mets ci-dessous une ébauche de code pour mieux comprendre.

Sub Macro1()

    Sheets("Accueil").Select
    Range("G8").Copy
    Sheets("Feuil6").Select
    Range("A65000").End(xlUp).Offset(1).Select
    ActiveSheet.Paste
    Sheets("Accueil").Select
    Range("C14").Copy
    Sheets("Feuil6").Select
    Range("B65000").End(xlUp).Offset(1, 0).Select
    ActiveSheet.Paste

End Sub

D'avance merci pour vos réponses.

 

[Robert]

Re : Copie de cellules non contigües

Bonjour Didou, bonjour le forum,

Peut-être comme ça :

Sub Macro1()
Dim pl As Range 'déclare la variable pl (PLage)
Dim cel As Range 'déclare la variable cel (CELlule)
Dim i As Byte 'déclare la variable i (Incrément)

With Sheets("Accueil") 'prend en compte l'onglet "Accueil"
    Set pl = Application.Union(.Range("G8"), .Range("C14"), .Range("J14"), .Range("E16")) 'définit la plage pl (à adapter à ton cas)
End With 'fin de la prise en compte de l'onglet "Accueil"
With Sheets("Feuil6") 'prend en compte l'onglet "Feuil6"
    i = 1 'définit la variable i
    For Each cel In pl 'boucle sur toutes les cellules cel de la plage pl
        cel.Copy .Cells(2, i) 'copie la cellule et la colle dans la cellule en ligne 2 colonne i
        i = i + 1 'incrémente i
    Next cel 'prochaine cellule de la boucle
End With 'fin de la prise en compte de l'onglet "Feuil6"
End Sub

 

[Didou59]

Re : Copie de cellules non contigües

Bonjour Robert,
Merci pour ta réactivité, cela fonctionne mais dès que je veux refaire une saisie ça copie toujours sur la première ligne. Je te mets le code pour info et pour mieux comprendre.

Sub Macro1()
Application.ScreenUpdating = False
Dim PL As Range
Dim cel As Range
Dim i As Byte
With Sheets("Accueil")
Set PL = Application.Union(.Range("G8"), .Range("C14"), .Range("J14"), .Range("E16"), .Range("J16"), .Range("D18"), .Range("j18"), .Range("d20"), .Range("j20"), .Range("d22"), .Range("j24"), .Range("c27:c34"), .Range("e27:e24"), .Range("g27:g34"), .Range("i27:i34"), .Range("k27:k34"))
End With
With Sheets("Feuil6")
    i = 1
    For Each cel In PL
        cel.Copy .Cells(2, i)
        i = i + 1
    Next cel
End With
    Dim cellules As String
    cellules = "G8,C14,j14,e16,j16,D18,j18,d20,d22,j24,c27:c34,e27:e34,g27:g34,i27:i34,k27:k34"
    Sheets("Accueil").Select
    Range(cellules).Value = ""
    Range("G8").Activate
Application.ScreenUpdating = True
ActiveWorkbook.Save
End Sub

 

[Didou59]

Re : Copie de cellules non contigües

Excuse moi Robert,
De plus ce sont les valeurs que je veux copier et non pas la cellule en elle même.

 

[Robert]

Re : Copie de cellules non contigües

Bonjour Didou, bonjour le forum,

J'avais pas bien compris... Essaie comme ça :

Sub Macro1()
Dim PL As Range
Dim cel As Range
Dim i As Byte
Dim li As Integer

Application.ScreenUpdating = False
With Sheets("Accueil")
    Set PL = Application.Union(.Range("G8"), .Range("C14"), .Range("J14"), .Range("E16"), .Range("J16"), .Range("D18"), .Range("J18"), .Range("D20"), .Range("J20"), _
       .Range("D22"), .Range("J24"), .Range("C27:C34"), .Range("E27:E24"), .Range("G27:G34"), .Range("I27:I34"), .Range("K27:K34"))
End With
With Sheets("Feuil6")
    li = IIf(.Range("A2").Value = "", 2, .Cells(Application.Rows.Count, 1).End(xlUp).Row + 1)
    i = 1
    For Each cel In PL
        .Cells(li, i).Value = cel.Value
        i = i + 1
    Next cel
End With
PL.ClearContents
Sheets("Accueil").Select
Range("G8").Activate
Application.ScreenUpdating = True
ActiveWorkbook.Save
End Sub

 

[Didou59]

Re : Copie de cellules non contigües

Robert, le code PL.ClearContents ne fonctionne pas.
Merci

 

[Robert]

Re : Copie de cellules non contigües

Bonjour Didou, bonjour le forum,

PL.ClearContents fonctionne chez moi. Ça efface le contenu des cellules. Si tu veux aussi effacer le format, remplace par PL.Clear

 

[Didou59]

Re : Copie de cellules non contigües

Excuse moi Robert, mais je viens de supprimer

PL.ClearContents

et la macro fonctionne. Je ne comprends pas pourquoi ce code ne fonctionne pas chez moi mais chez toi si. Par contre grand merci pour la macro qui correspond à ce que je veux. Je ferai évoluer en fonction de la finalisation du fichier que je désire.
Merci,

 

[Robert]

Re : Copie de cellules non contigües

Bonjour Didou, bonjour le forum,

Je ne comprends pas pourquoi ce dysfonctionnement... Essaie d'inverser les lignes

PL.ClearContents
Sheets("Accueil").Select

par

Sheets("Accueil").Select
PL.ClearContents

 

[Didou59]

Re : Copie de cellules non contigües

Robert,
Préconisation que j'ai essayé mais qui ne fonctionne pas. J'essaie de trouver une autre méthode pour la remise à zéro.

 

[Didou59]

Re : Copie de cellules non contigües

Robert,
Après plusieurs test et recherches sur le web, voici un code qui fonctionne

PL.Select
Selection.ClearContents

Ce n'est peut-être pas si élégant que ton code mais ça fontionne.
Encore merci et à bientôt.