VBA Copier Coller vers cellule spécifique d'un fichier vers un autre

[texser]

Bonjour tout le monde,

J'ai un petit problème concernant un code VBA.

Je désire copier d'un fichier A cellule A2 vers fichier B cellule A16
Puis de Fichier A cellule A3 Vers fichier B cellule A23
ect...

J'ai découvert et modifié ce code qui marche assez bien mais dès que je dépasse un certain nombre de lignes il me dit que le procédure est trop longue....

La cellule a copier dans fichier A est toujours +1 et dans le fichier B (source) toujours +7

Pouvez-vous m'aider svp

Merci d'avance


Ci-joint le code:

Sub CopierDonnees()

Dim Entree As Workbook, Sortie As Workbook

Nomfichierentree = Application.GetOpenFilename("Fichier Excel (*.xls), *.xsl")
' On verifie que l'on a selectionné un nom de classeur
If Nomfichierentree <> False Then
    ' On ouvre le classeur
    Set Entree = Workbooks.Open(Nomfichierentree)

   
    NomFichierSortie = Application.GetOpenFilename("Fichier Excel (*.xls), *.xsl")
    If NomFichierSortie <> False Then
        Set Sortie = Workbooks.Open(NomFichierSortie)
       
        '  Ici tu mets les copies des cellules de la feuille d'entrée vers la feuille de sortie
        Sortie.Worksheets("Feuil2").Cells(16, 1) = Entree.Worksheets("Feuil1").Cells(2, 1)
Sortie.Worksheets("Feuil2").Cells(23, 1) = Entree.Worksheets("Feuil1").Cells(3, 1)
Sortie.Worksheets("Feuil2").Cells(30, 1) = Entree.Worksheets("Feuil1").Cells(4, 1)
Sortie.Worksheets("Feuil2").Cells(37, 1) = Entree.Worksheets("Feuil1").Cells(5, 1)
Sortie.Worksheets("Feuil2").Cells(44, 1) = Entree.Worksheets("Feuil1").Cells(6, 1)
Sortie.Worksheets("Feuil2").Cells(51, 1) = Entree.Worksheets("Feuil1").Cells(7, 1)
Sortie.Worksheets("Feuil2").Cells(58, 1) = Entree.Worksheets("Feuil1").Cells(8, 1)
Sortie.Worksheets("Feuil2").Cells(65, 1) = Entree.Worksheets("Feuil1").Cells(9, 1)
Sortie.Worksheets("Feuil2").Cells(72, 1) = Entree.Worksheets("Feuil1").Cells(10, 1)
Sortie.Worksheets("Feuil2").Cells(79, 1) = Entree.Worksheets("Feuil1").Cells(11, 1)
Sortie.Worksheets("Feuil2").Cells(86, 1) = Entree.Worksheets("Feuil1").Cells(12, 1)
Sortie.Worksheets("Feuil2").Cells(93, 1) = Entree.Worksheets("Feuil1").Cells(13, 1)
Sortie.Worksheets("Feuil2").Cells(100, 1) = Entree.Worksheets("Feuil1").Cells(14, 1)
Sortie.Worksheets("Feuil2").Cells(107, 1) = Entree.Worksheets("Feuil1").Cells(15, 1)
Sortie.Worksheets("Feuil2").Cells(114, 1) = Entree.Worksheets("Feuil1").Cells(16, 1)
Sortie.Worksheets("Feuil2").Cells(121, 1) = Entree.Worksheets("Feuil1").Cells(17, 1)
Sortie.Worksheets("Feuil2").Cells(128, 1) = Entree.Worksheets("Feuil1").Cells(18, 1)
Sortie.Worksheets("Feuil2").Cells(135, 1) = Entree.Worksheets("Feuil1").Cells(19, 1)
Sortie.Worksheets("Feuil2").Cells(142, 1) = Entree.Worksheets("Feuil1").Cells(20, 1)
Sortie.Worksheets("Feuil2").Cells(149, 1) = Entree.Worksheets("Feuil1").Cells(21, 1)
Sortie.Worksheets("Feuil2").Cells(156, 1) = Entree.Worksheets("Feuil1").Cells(22, 1)
Sortie.Worksheets("Feuil2").Cells(163, 1) = Entree.Worksheets("Feuil1").Cells(23, 1)
Sortie.Worksheets("Feuil2").Cells(170, 1) = Entree.Worksheets("Feuil1").Cells(24, 1)
Sortie.Worksheets("Feuil2").Cells(177, 1) = Entree.Worksheets("Feuil1").Cells(25, 1)
Sortie.Worksheets("Feuil2").Cells(184, 1) = Entree.Worksheets("Feuil1").Cells(26, 1)
Sortie.Worksheets("Feuil2").Cells(191, 1) = Entree.Worksheets("Feuil1").Cells(27, 1)


        'Sortie Toujours +7   Entree toujours +1
       
       
        '   etc
        '   .
        '   .
        '   .
   
        ' On ferme le classeur
        Sortie.Close
   
   
    End If
    ' On ferme le second
    Entree.Close
End If


End Sub

 

[Robert]

Bonjour Texser, bonjour le forum,

Essaie comme ça :

Sub CopierDonnees()
Dim F As Variant
Dim CE As Workbook
Dim OE As Worksheet
Dim CS As Workbook
Dim OS As Worksheet


F = Application.GetOpenFilename("Fichier Excel (*.xls), *.xsl")
' On verifie que l'on a selectionné un nom de classeur
If F = False Then Exit Sub
Set CE = Workbooks.Open(F)
Set OE = CE.Worksheets("Feuil1")
F = Application.GetOpenFilename("Fichier Excel (*.xls), *.xsl")
If F = False Then Exit Sub
Set CS = Workbooks.Open(F)
Set OS = CE.Worksheets("Feuil2")

'  Ici tu mets les copies des cellules de la feuille d'entrée vers la feuille de sortie
OS.Cells(16, 1) = OE.Cells(2, 1)
OS.Cells(23, 1) = OE.Cells(3, 1)
OS.Cells(30, 1) = OE.Cells(4, 1)
OS.Cells(37, 1) = OE.Cells(5, 1)
OS.Cells(44, 1) = OE.Cells(6, 1)
OS.Cells(51, 1) = OE.Cells(7, 1)
OS.Cells(58, 1) = OE.Cells(8, 1)
OS.Cells(65, 1) = OE.Cells(9, 1)
OS.Cells(72, 1) = OE.Cells(10, 1)
OS.Cells(79, 1) = OE.Cells(11, 1)
OS.Cells(86, 1) = OE.Cells(12, 1)
OS.Cells(93, 1) = OE.Cells(13, 1)
OS.Cells(100, 1) = OE.Cells(14, 1)
OS.Cells(107, 1) = OE.Cells(15, 1)
OS.Cells(114, 1) = OE.Cells(16, 1)
OS.Cells(121, 1) = OE.Cells(17, 1)
OS.Cells(128, 1) = OE.Cells(18, 1)
OS.Cells(135, 1) = OE.Cells(19, 1)
OS.Cells(142, 1) = OE.Cells(20, 1)
OS.Cells(149, 1) = OE.Cells(21, 1)
OS.Cells(156, 1) = OE.Cells(22, 1)
OS.Cells(163, 1) = OE.Cells(23, 1)
OS.Cells(170, 1) = OE.Cells(24, 1)
OS.Cells(177, 1) = OE.Cells(25, 1)
OS.Cells(184, 1) = OE.Cells(26, 1)
OS.Cells(191, 1) = OE.Cells(27, 1)
CS.Close True
CE.Close
End Sub

 

[texser]

Bonjour Robert,

Merci pour ta réponse rapide. Le problème est que j'ai 600 x 14 cellules a copier dans un ordre spécifique et j'ai peur q'en faisant ainsi j'ai le même problème. Que la procédure soit trop longue....

Je pensait que je pouvais prendre toutes les cellules du fichier A colonne A1, puis A2 ect +1 à chaque fois et les coller Fichier B colonne A16, puis A23 ect +7 à chaque fois en une seule ligne

comme cela j'aurais en tout 14 lignes de programmation au lieu de 600x14

je ne sais pas si je me suis bien exprimé....

 

[Robert]

Re,

Je pense que ton problème de procédure trop longue venait du fait qu'elle se situait entre le If et le Enf If. Ce n'est plus le cas. As-tu testé le code proposé ?
Après, si tu peux boucler c'est évidemment plus simple. Mais sans fichier je ne peux pas t'aider davantage.

 

[texser]

Re,

J'ai essayé ton code. Me mets une erreur 9 l indice n'appartient pas à la sélection au niveau:

Set OS = CE.Worksheets("Feuil2")

Merci pour ta patience

 

[texser]

Re,

Ci joint le fichier A qu'il faut copier vers fichier b avec le fichier test sur le quel il y a votre code vba

 

[Paf]

Bonjour texser, Robert

en passant par une boucle on réduirait le nombre de lignes de code.
Ainsi

Sortie.Worksheets("Feuil2").Cells(16, 1) = Entree.Worksheets("Feuil1").Cells(2, 1)
Sortie.Worksheets("Feuil2").Cells(23, 1) = Entree.Worksheets("Feuil1").Cells(3, 1)
.....
Sortie.Worksheets("Feuil2").Cells(184, 1) = Entree.Worksheets("Feuil1").Cells(26, 1)
Sortie.Worksheets("Feuil2").Cells(191, 1) = Entree.Worksheets("Feuil1").Cells(27, 1)

se réduirait à

x=1
For i= 16 to 191 step 7 ' à adapter aux lignes à traiter
    x=x+1
    Sortie.Worksheets("Feuil2").Cells(i, 1) = Entree.Worksheets("Feuil1").Cells(x, 1)
Next

on pourrait également adopter l'écriture plus légère proposée par Robert.

A+

 

[texser]

Bonjour Paf,

Merci pour ton code magique. lol Il convient tout à fait à mes besoins.

Encore un grand merci à Robert et Paf pour leur partage et pour votre temps.