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

[benadry]

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 :

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.

 

[Robert]

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 :

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

 

[benadry]

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 :

With Workbooks(Chemin2 & Fichier4).ActiveSheet

que j'ai transformée en :

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

Et ça ne marche pas mieux !

Merci par avance pour ton aide.

Cordialement.

 

[Pierrot93]

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

Bonjour,

essaye peut être ceci, le "fichier4" doit être ouvert :

With Workbooks(Fichier4).Sheets("Feuil1")

bonne journée
@+

 

[benadry]

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

Bonjour Pierrot,

Ca ne marche pas non plus.

Cordialement.

 

[Pierrot93]

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

Re,

bah... vérifie bien le nom du classeur et de la feuille et ce que vaut ta variable.... rappel, le classeur en question doit être ouvert....

 

[benadry]

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 :

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

Workbooks(Chemin2 & Fichier4).Open

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

Merci d'avance.

Cordialement.

 

[Pierrot93]

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

Re,

c'est plus sur la même instruction déjà....

essaye ceci pour la méthode "open" :

Workbooks.Open Chemin2 & Fichier4

 

[benadry]

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 :

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.