Macro Excel pour copier des cellules non contigües d'un classeur vers un autre

  • Initiateur de la discussion Initiateur de la discussion benadry
  • Date de début Date de début

Boostez vos compétences Excel avec notre communauté !

Rejoignez Excel Downloads, le rendez-vous des passionnés où l'entraide fait la force. Apprenez, échangez, progressez – et tout ça gratuitement ! 👉 Inscrivez-vous maintenant !

benadry

XLDnaute Occasionnel
Bonjour le forum,


J'ai élaboré une macro qui, partant d'un formulaire type sous Excel enregistre dans des répertoires différents en fonction de la valeur de la cellule A9, puis ferme le classeur ainsi obtenu et revient au classeur type.

Tout cela fonctionne très bien.

Je voudrais maintenant qu'avant de fermer le classeur de destination, la macro copie un certain nombre de cellules non contigües dans un autre classeur, à des fins statistiques.

Or, c'est là que je bute, car la macro que j'ai réalisée me dit qu'il ne peut pas traiter des cellules non contigües.

Je pense que je pourrai sélectionner la cellule, la copier dans la feuille de destination, revenir à la feuille d'origine, resélectionner une cellule ... Mais, je souhaiterais savoir s'il n'y a pas un moyen plus aisé.

Voici mon code :

Code:
Sub Enreg()

Dim chemin, Chemin2, Repertoire, Fichier, Fichier2, Fichier4, Rep As String

chemin = "G:\XXX\YYY\ZZZ\AAA\BBB\CCC\"
Chemin2 = "G:\XXX\YYY\ZZZ\AAA\BBB\"

Repertoire = [A9].Value & "\"
Fichier = "Fiche anomalieModèle.xlsm"
Fichier2 = Sheets("Feuil2").[E1].Value & ".xlsm"
Fichier4 = "ExtractionContrôles.xlsx"

ActiveWorkbook.SaveAs Filename:=chemin & Repertoire & Fichier2, FileFormat:=xlOpenXMLWorkbookMacroEnabled

ActiveWorkbook.Sheets("Feuil2").Select
Application.Union(Cells(7, 5), Cells(8, 1), Cells(8, 2), Cells(8, 5), Cells(12, 2), Cells(14, 2), Cells(14, 5), Cells(16, 2), Cells(16, 5)).Select 'selection des données que l’on veut importer
Selection.Copy 'copie les données sélectionnées

Workbooks(Chemin2 & Fichier4).Activate 'retourne vers le fichier de départ
i = ActiveSheet.UsedRange.Rows.Count 'compte le nombre de lignes déjà utilisées dans ce fichier
Cells(i + 1, 1).Select 'sélection de la cellule où on veut coller les données (la première vide)
ActiveSheet.Paste 'colle les données
Workbooks(Chemin2 & Fichier4).Close SaveChanges:=True

Rep = MsgBox("Voulez-vous revenir au modèle et fermer la présente fiche anomalie ?", vbYesNo + vbQuestion, "Le programme demande votre attention")
If Rep = vbYes Then
Workbooks.Open Filename:=chemin & Fichier
Workbooks(Fichier2).Close SaveChanges:=False

End If

End Sub


Merci d'avance.

Cordialement.
 
Re : Macro Excel pour copier des cellules non contigües d'un classeur vers un autre

Bonsoir Benadry, bonsoir le forum,

Peut-être comme ça :
Code:
Sub Enreg()
Dim chemin As String, Chemin2 As String, Repertoire As String, Fichier As String, Fichier2 As String, Fichier4 As String, Rep As String
Dim pl As Range
Dim i As Long
Dim cel As Range

chemin = "G:\XXX\YYY\ZZZ\AAA\BBB\CCC\"
Chemin2 = "G:\XXX\YYY\ZZZ\AAA\BBB\"
Repertoire = Range("A9").Value & "\"
Fichier = "Fiche anomalieModèle.xlsm"
Fichier2 = Sheets("Feuil2").Range("E1").Value & ".xlsm"
Fichier4 = "ExtractionContrôles.xlsx"
ActiveWorkbook.SaveAs Filename:=chemin & Repertoire & Fichier2, FileFormat:=xlOpenXMLWorkbookMacroEnabled
With Sheets("Feuil2")
    'définit la plage pl des données que l’on veut importer
    Set pl = Application.Union(.Cells(7, 5), .Cells(8, 1), .Cells(8, 2), .Cells(8, 5), .Cells(12, 2), .Cells(14, 2), .Cells(14, 5), .Cells(16, 2), .Cells(16, 5))
End With
With Workbooks(Chemin2 & Fichier4).ActiveSheet 'prend en compte le fichier de départ
    i = .UsedRange.Rows.Count 'compte le nombre de lignes déjà utilisées dans ce fichier
    For Each cel In pl
        cel.Copy .Cells(i + 1, 1)
        i = i + 1
    Next cel
End With
Workbooks(Chemin2 & Fichier4).Close SaveChanges:=True
Rep = MsgBox("Voulez-vous revenir au modèle et fermer la présente fiche anomalie ?", vbYesNo + vbQuestion, "Le programme demande votre attention")
If Rep = vbYes Then
    Workbooks.Open Filename:=chemin & Fichier
    Workbooks(Fichier2).Close SaveChanges:=False
End If
End Sub
 
Re : Macro Excel pour copier des cellules non contigües d'un classeur vers un autre

Bonjour Robert,
Bonjour le forum,

Merci pour ton aide.

J'ai une erreur d'exécution 9 - l'indice n'apaprtient pas à la sélection à la ligne :

Code:
With Workbooks(Chemin2 & Fichier4).ActiveSheet

que j'ai transformée en :

Code:
With Workbooks(Chemin2 & Fichier4).Sheets("Feuil1")

Et ça ne marche pas mieux !

Merci par avance pour ton aide.

Cordialement.
 
Re : Macro Excel pour copier des cellules non contigües d'un classeur vers un autre

Re-,

Je ne comprends pas !

Le chemin, la feuille et le fichier sont "bons". J'ai ouvert, puis activé le fichier de destination et ça ne fonctionne pas !

Voici mon code :

Code:
Sub Enreg()
Dim chemin As String, Chemin2 As String, Repertoire As String, Fichier As String, Fichier2 As String, Fichier4 As String, Rep As String
Dim pl As Range
Dim i As Long
Dim cel As Range


chemin = "G:\XXX\YYY\ZZZ\AAA\BBB\CCC\"
Chemin2 = "G:\XXX\YYY\ZZZ\AAA\BBB\"
Repertoire = Range("A9").Value & "\"
Fichier = "Fiche anomalieModèle.xlsm"
Fichier2 = Sheets("Feuil2").Range("E1").Value & ".xlsm"
Fichier4 = "Extraction.xlsx"
ActiveWorkbook.SaveAs Filename:=chemin & Repertoire & Fichier2, FileFormat:=xlOpenXMLWorkbookMacroEnabled

With Sheets("Feuil2")
    'définit la plage pl des données que l’on veut importer
    Set pl = Application.Union(.Cells(7, 5), .Cells(8, 1), .Cells(8, 2), .Cells(8, 5), .Cells(12, 2), .Cells(14, 2), .Cells(14, 5), .Cells(16, 2), .Cells(16, 5))
End With

Workbooks(Chemin2 & Fichier4).Open
Workbooks(Chemin2 & Fichier4).Activate

With Workbooks(Chemin2 & Fichier4).Sheets("Feuil1") 'prend en compte le fichier de départ
i = .UsedRange.Rows.Count 'compte le nombre de lignes déjà utilisées dans ce fichier
    For Each cel In pl
        cel.Copy .Cells(i + 1, 1)
        i = i + 1
    Next cel
End With

Workbooks(Chemin2 & Fichier4).Close SaveChanges:=True
Rep = MsgBox("Voulez-vous revenir au modèle et fermer la présente fiche anomalie ?", vbYesNo + vbQuestion, "Le programme demande votre attention")
If Rep = vbYes Then
    Workbooks.Open Filename:=chemin & Fichier
    Workbooks(Fichier2).Close SaveChanges:=False
End If
End Sub

J'ai toujours la même erreur d'exécution 9 à la ligne
Code:
Workbooks(Chemin2 & Fichier4).Open

Si quelqu'un a une idée ...

Merci d'avance.

Cordialement.
 
Re : Macro Excel pour copier des cellules non contigües d'un classeur vers un autre

Re-,

Comme ça ne fonctionnait pas, j'ai changé avec le code suivant et, cette fois-ci, c'est bon !

En voici un extrait :

Code:
ActiveWorkbook.SaveAs Filename:=chemin & Repertoire & Fichier2, FileFormat:=xlOpenXMLWorkbookMacroEnabled

With Sheets("Feuil2")
    'définit la plage pl des données que l’on veut importer
    Set pl = Application.Union(.Cells(8, 5), .Cells(9, 1), .Cells(9, 2), .Cells(9, 5), .Cells(13, 2), .Cells(15, 2), .Cells(15, 5), .Cells(17, 2), .Cells(17, 5))
End With

Workbooks.Open Chemin2 & Fichier4

With ActiveWorkbook.Sheets("Feuil1")

i = .UsedRange.Rows.Count 'compte le nombre de lignes déjà utilisées dans ce fichier
    For Each cel In pl
        cel.Copy .Cells(i + 1, 1)
        i = i + 1
    Next cel
End With

ActiveWorkbook.Close SaveChanges:=True

Merci pour votre aide en tout cas.


Cordialement.
 
- Navigue sans publicité
- Accède à Cléa, notre assistante IA experte Excel... et pas que...
- Profite de fonctionnalités exclusives
Ton soutien permet à Excel Downloads de rester 100% gratuit et de continuer à rassembler les passionnés d'Excel.
Je deviens Supporter XLD

Discussions similaires

Retour