XL 2010 Copier données dans une feuille d'un autre classeur

[TOINE38]

Bonjour à tous,

N'étant pas très "fortiche" en vba, j'ai quand même réussi à créer un petit programme qui me copie des données d'une feuille vers une autre feuille du même classeur à des positions bien précise.
Mon problème et que je souhaiterais faire la même chose mais que la copie des données se fasse dans une feuille d'un autre classeur, et là c'est la cata, impossible de trouver malgré plusieurs recherche sur le net.
Si quelqu'un aurais une astuce pour m'aider à solutionner ce problème ce serais super.

ci dessous mon code qu'il faudrait que j'adapte

Sub transfert_base()
Dim Nblg As Long
Application.ScreenUpdating = False
Nblg = Range("A" & Rows.Count).End(xlUp).Row
Range("A2:H" & Nblg).AutoFilter field:=8, Criteria1:="1"
If Application.Subtotal(103, Range("A3:A" & Nblg)) > 0 Then
With Sheets("Extract")
.Cells.Clear
Range("b3:b" & Nblg).SpecialCells(xlCellTypeVisible).Copy .Range("c6")
Range("c3:c" & Nblg).SpecialCells(xlCellTypeVisible).Copy .Range("d6")
Range("d3:d" & Nblg).SpecialCells(xlCellTypeVisible).Copy .Range("i6")
Range("e3:e" & Nblg).SpecialCells(xlCellTypeVisible).Copy .Range("j6")
Range("f3:f" & Nblg).SpecialCells(xlCellTypeVisible).Copy .Range("k6")
Range("g3:g" & Nblg).SpecialCells(xlCellTypeVisible).Copy .Range("l6")
End With
ActiveSheet.AutoFilterMode = False
End If
End Sub

Merci d'avance pour toute aide

Cordialement

Toine38

 

[Robert]

Bonjour Toine, bonjour le forum,

Si les deux classeurs sont ouverts (nom des onglets à adapter) :

Sub transfert_base()
Dim CS As Workbook 'déclare la variable CS (Classeur Source)
Dim OS As Worksheet 'déclare la variable OS (Onglet Source)
Dim CD As Workbook 'déclare la variable CD (Classeur Destination)
Dim OD As Worksheet 'déclare la variable OD (Onglet Destination)

Set CS = ThisWorkbook
Set OS = CS.Worksheets("Feuil1") 'à adapter à ton cas
Set CD = Workbooks("Ton_Classeur_destination_ouvert.xls") 'à adapter à ton cas
Set OD = CD.Worksheets("Extract") 'à modifier si besoin

Dim Nblg As Long
Application.ScreenUpdating = False
Nblg = OS.Range("A" & Rows.Count).End(xlUp).Row
OS.Range("A2:H" & Nblg).AutoFilter field:=8, Criteria1:="1"
If Application.Subtotal(103, OS.Range("A3:A" & Nblg)) > 0 Then
  OD.Cells.Clear
  OS.Range("b3:b" & Nblg).SpecialCells(xlCellTypeVisible).Copy OD.Range("c6")
  OS.Range("c3:c" & Nblg).SpecialCells(xlCellTypeVisible).Copy OD.Range("d6")
  OS.Range("d3:d" & Nblg).SpecialCells(xlCellTypeVisible).Copy OD.Range("i6")
  OS.Range("e3:e" & Nblg).SpecialCells(xlCellTypeVisible).Copy OD.Range("j6")
  OS.Range("f3:f" & Nblg).SpecialCells(xlCellTypeVisible).Copy OD.Range("k6")
  OS.Range("g3:g" & Nblg).SpecialCells(xlCellTypeVisible).Copy OD.Range("l6")
  OS.AutoFilterMode = False
End If
End Sub

 

[TOINE38]

Bonjour Robert
Merci beaucoup pour ce code, c'est impeccable, on reconnait là le travail d'un pro.
J'aimerais bien être à ce niveau, mais en autodidacte ce n'est pas facile.

J'aurais encore un point à améliorer qui est :
Le code doit être dans le classeur de destination car c'est de là que je dois lancer la macro
Le classeur source est fermé , il peut être ouvert temporairement mais doit au final être refermé.

Merci d'avance pour ton aide

cordialement

Toine 38

 

[Robert]

Re,

Ça devrait donner ça :

Sub transfert_base()
Dim CS As Workbook 'déclare la variable CS (Classeur Source)
Dim CH As String 'déclare la variable CH (Chemin d'accès)
Dim OS As Worksheet 'déclare la variable OS (Onglet Source)
Dim CD As Workbook 'déclare la variable CD (Classeur Destination)
Dim OD As Worksheet 'déclare la variable OD (Onglet Destination)

Set CD = ThisWorkbook
Set OD = CD.Worksheets("Extract")
CH = "Ici le chemin d'accès au classeur source" & "\" 'à définir
Set CS = Workbooks.Open(CH & "Ton_Classeur_Source.xls") 'à adapter à ton cas
Set OS = CS.Worksheets("Feuil1") 'à adapter à ton cas

Dim Nblg As Long
Application.ScreenUpdating = False
Nblg = OS.Range("A" & Rows.Count).End(xlUp).Row
OS.Range("A2:H" & Nblg).AutoFilter field:=8, Criteria1:="1"
If Application.Subtotal(103, OS.Range("A3:A" & Nblg)) > 0 Then
  OD.Cells.Clear
  OS.Range("b3:b" & Nblg).SpecialCells(xlCellTypeVisible).Copy OD.Range("c6")
  OS.Range("c3:c" & Nblg).SpecialCells(xlCellTypeVisible).Copy OD.Range("d6")
  OS.Range("d3:d" & Nblg).SpecialCells(xlCellTypeVisible).Copy OD.Range("i6")
  OS.Range("e3:e" & Nblg).SpecialCells(xlCellTypeVisible).Copy OD.Range("j6")
  OS.Range("f3:f" & Nblg).SpecialCells(xlCellTypeVisible).Copy OD.Range("k6")
  OS.Range("g3:g" & Nblg).SpecialCells(xlCellTypeVisible).Copy OD.Range("l6")
  OS.AutoFilterMode = False
End If
CS.Close False
End Sub

 

[TOINE38]

Milles Merci Robert, c'est parfait.

Bonne fin de weekend

cordialement

toine38