Feuille récap dans un autre répertoire!!!

[la croisée des pains]

bonjour a tous,
j'ai un ptit souci, rien de grave...
J'aimerais envoyer les données de mes tableaux dans un classeur du meme repertoire nommer Récap dans la feuille qui s'apelle Recap_année

mon code suivant marche bien sur mon classeur de saisie commande avec cette feuille qui s'apelle Recap_année mais maintenant j'aimerais enlever cette feuille et la mettre dans mon nouveau repertoire nommer Récap.

Coment je dois modifier ce code...et le top serait que celui-ci soit fermer lors de l'archivage(le classeur!!!)....

merci de votre aide
lolo


Sub Archives()
'
' Archives Macro

Jjour = Range("B1")
For Each cel In Sheets("Recap_année").Range("A:A")
If cel.Value = Jjour Then
MsgBox ("Journée déjà archivée.")
Exit Sub
End If
Next
ligmax = Sheets("Recap_année").Range("A65000").End(xlUp).Row + 1
cible = "A" & ligmax & ":A" & ligmax + 10
Sheets("Recap_année").Range("A" & ligmax & ":A" & ligmax + 10) = Jjour
Range("B3:L3,B10:L10,b11:l11").Copy
Sheets("Recap_année").Select
Range("B" & ligmax).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=True
Application.CutCopyMode = False

Sheets("Calcul").Select
ligmax = Sheets("Recap_année").Range("A65000").End(xlUp).Row + 1
cible = "A" & ligmax & ":A" & ligmax + 7
Sheets("Recap_année").Range("A" & ligmax & ":A" & ligmax + 7) = Jjour
Range("i1515,i1616,i1717").Copy
Sheets("Recap_année").Select
Range("B" & ligmax).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=True
Application.CutCopyMode = False

Sheets("Calcul").Select
ligmax = Sheets("Recap_année").Range("A65000").End(xlUp).Row + 1
cible = "A" & ligmax & ":A" & ligmax + 7
Sheets("Recap_année").Range("A" & ligmax & ":A" & ligmax + 7) = Jjour
Range("i1919,i2020,i2121").Copy
Sheets("Recap_année").Select
Range("B" & ligmax).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=True
Application.CutCopyMode = False

Sheets("Calcul").Select
MsgBox ("Journée archivée.")

End Sub

 

[Compte Supprimé 979]

Re : Feuille récap dans un autre répertoire!!!

Salut La Croisée des Pains

Essaye ce code pour commencer

Option Explicit
Sub Archives()
Dim Cel As Range, Cible As String, LigMax As Long
Dim DerLig As Long, Lig As Long, Jjour
Dim VFicPath As String
Dim WbkC As Workbook, ShtC As String
Dim WbkR As Workbook, ShtR As String
' Initialisation des variables
Set WbkC = ThisWorkbook
ShtC = "Calcul"
' Ouvrir le classeur des récaps
VFicPath = ThisWorkbook.Path & "\" & "Récap.xls"
Workbooks.Open VFicPath
Set WbkR = ActiveWorkbook
ShtR = "Recap_année"
Jjour = WbkC.Sheets(ShtC).Range("B1")
DerLig = WbkR.Sheets(ShtR).Range("A" & Rows.Count).End(xlUp).Row
For Lig = 1 To DerLig
If WbkR.Sheets(ShtR).Range("A" & Lig).Value = Jjour Then
  MsgBox ("Journée déjà archivée.")
  Exit Sub
End If
Next
ThisWorkbook.Activate
LigMax = WbkR.Sheets(ShtR).Range("A65000").End(xlUp).Row + 1
Cible = "A" & LigMax & ":A" & LigMax + 10
WbkR.Sheets(ShtR).Range("A" & LigMax & ":A" & LigMax + 10) = Jjour
WbkC.Sheets(ShtC).Range("B3:L3,B10:L10,b11:l11").Copy
WbkR.Sheets(ShtR).Range("B" & LigMax).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
  SkipBlanks:=False, Transpose:=True
Application.CutCopyMode = False
LigMax = WbkR.Sheets(ShtR).Range("A65000").End(xlUp).Row + 1
Cible = "A" & LigMax & ":A" & LigMax + 7
WbkR.Sheets(ShtR).Range("A" & LigMax & ":A" & LigMax + 7) = Jjour
WbkC.Sheets(ShtC).Range("i1515,i1616,i1717").Copy
WbkR.Sheets(ShtR).Range("B" & LigMax).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
  SkipBlanks:=False, Transpose:=True
Application.CutCopyMode = False
Sheets("Calcul").Select
LigMax = WbkR.Sheets(ShtR).Range("A65000").End(xlUp).Row + 1
Cible = "A" & LigMax & ":A" & LigMax + 7
WbkR.Sheets(ShtR).Range("A" & LigMax & ":A" & LigMax + 7) = Jjour
WbkC.Sheets(ShtC).Range("i1919,i2020,i2121").Copy
WbkR.Sheets(ShtR).Range("B" & LigMax).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
  SkipBlanks:=False, Transpose:=True
Application.CutCopyMode = False
WbkC.Sheets(ShtC).Select
WbkR.Close SaveChanges:=xlYes
MsgBox ("Journée archivée.")
End Sub

Tiens nous au courant

A+

 

[la croisée des pains]

Re : Feuille récap dans un autre répertoire!!!

bonsoir le forum,
bonsoir Bruno,

je n'ai pas encore testé le code, beaucoup de boulot ce wkend...
je verrais en début de semaine...mais déja merci de ton aide...

bon week-end a tous..

lolo

 

[la croisée des pains]

Re : Feuille récap dans un autre répertoire!!!

Salut La Croisée des Pains

Essaye ce code pour commencer

Option Explicit
Sub Archives()
Dim Cel As Range, Cible As String, LigMax As Long
Dim DerLig As Long, Lig As Long, Jjour
Dim VFicPath As String
Dim WbkC As Workbook, ShtC As String
Dim WbkR As Workbook, ShtR As String
' Initialisation des variables
Set WbkC = ThisWorkbook
ShtC = "Calcul"
' Ouvrir le classeur des récaps
VFicPath = ThisWorkbook.Path & "\" & "Récap.xls"
Workbooks.Open VFicPath
Set WbkR = ActiveWorkbook
ShtR = "Recap_année"
Jjour = WbkC.Sheets(ShtC).Range("B1")
DerLig = WbkR.Sheets(ShtR).Range("A" & Rows.Count).End(xlUp).Row
For Lig = 1 To DerLig
If WbkR.Sheets(ShtR).Range("A" & Lig).Value = Jjour Then
  MsgBox ("Journée déjà archivée.")
  Exit Sub
End If
Next
ThisWorkbook.Activate
LigMax = WbkR.Sheets(ShtR).Range("A65000").End(xlUp).Row + 1
Cible = "A" & LigMax & ":A" & LigMax + 10
WbkR.Sheets(ShtR).Range("A" & LigMax & ":A" & LigMax + 10) = Jjour
WbkC.Sheets(ShtC).Range("B3:L3,B10:L10,b11:l11").Copy
WbkR.Sheets(ShtR).Range("B" & LigMax).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
  SkipBlanks:=False, Transpose:=True
Application.CutCopyMode = False
LigMax = WbkR.Sheets(ShtR).Range("A65000").End(xlUp).Row + 1
Cible = "A" & LigMax & ":A" & LigMax + 7
WbkR.Sheets(ShtR).Range("A" & LigMax & ":A" & LigMax + 7) = Jjour
WbkC.Sheets(ShtC).Range("i1515,i1616,i1717").Copy
WbkR.Sheets(ShtR).Range("B" & LigMax).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
  SkipBlanks:=False, Transpose:=True
Application.CutCopyMode = False
Sheets("Calcul").Select
LigMax = WbkR.Sheets(ShtR).Range("A65000").End(xlUp).Row + 1
Cible = "A" & LigMax & ":A" & LigMax + 7
WbkR.Sheets(ShtR).Range("A" & LigMax & ":A" & LigMax + 7) = Jjour
WbkC.Sheets(ShtC).Range("i1919,i2020,i2121").Copy
WbkR.Sheets(ShtR).Range("B" & LigMax).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
  SkipBlanks:=False, Transpose:=True
Application.CutCopyMode = False
WbkC.Sheets(ShtC).Select
WbkR.Close SaveChanges:=xlYes
MsgBox ("Journée archivée.")
End Sub

Tiens nous au courant

A+

bonjour à tous,
bonjour Bruno,

c'est nickel...le code marche très bien..
je te remercie de ton aide si précieuse...
a binetôt

laurent

 

[Compte Supprimé 979]

Re : Feuille récap dans un autre répertoire!!!

Salut Laurent,

Sur ce coup là, j'ai vraiment du bol

A+