Archiver une feuille dans un nouveau classeur par mois
Bonjour tout le monde
Voila je voudrais faire quelque chose:
j'ai un classeur avec au final une feuille de synthese que je voudrais archivé.
Jai dans l'idée d'archiver cette feuile sur un autre classeur et en fait, il y auras suivant les jours de 10 a 15 feuilles par jour je voudrais donc a chaque feuille la copier sur une nouvele feuille du casseur "archive" donc créer a chaque fois dans le classeur "archive" une nouvelle feuille et la nommé du nom de la cellule A1 (qui est une date) de la feuille a archiver,
mais j'aimerais qu'il y ai création d'un nouveau classeur archive sous le nom "archive_mois_années" donc a chaque changement de mois et donc archiver chaque feuille dans le dossier du meme mois (d'apres la cellule du mois de la cellule A1)
Voila, j'espers que je suis assez clair mais dites moi si vous voulez des precisions
merci pour votre aide.
Cordialement
Salut le forum
Maguetlolo, je te donne la base de la macro
Function ExistenceFichier(sFichier As String) As Boolean
ExistenceFichier = Dir(sFichier) <> ""
End Function
Sub Tester()
Dim sNomFichier As String
sNomFichier = "C:\Archivages\" & "Archive_" & Format(Range("A1"), "mm") & "_" & Format(Range("A1"), "yyyy") & ".xls"
If ExistenceFichier(sNomFichier) Then
'On copie les données
MsgBox ("Le fichier existe")
Else
'Création du fichier avant la copie
MsgBox ("Le fichier n'existe pas")
Creation_Fichier
End If
End Sub
Private Sub Creation_Fichier()
'Activer la référence "Microsoft excel 11.0 object library"
Dim xlApp As New Excel.Application
Dim xlBook As Workbook
Dim NomFichier As String
Set xlApp = CreateObject("Excel.Application")
Set xlBook = xlApp.Workbooks.Add
xlApp.Visible = True
NomFichier = "C:\Archivages\" & "Archive_" & Format(Range("A1"), "mm") & "_" & Format(Range("A1"), "yyyy")
xlBook.SaveAs NomFichier
xlBook.Close
xlApp.Quit
Set xlBook = Nothing
Set xlApp = Nothing
End SubMytå
Bonsoir tout le monde,
Merci Myta, ca marche bien
mais j'ai un soucis maintenant, c'est pour coller la feuille active du classeur ouvert(cellule A1:O60) dans le classeur "archive & mois de la cellule A1" tout en créant une nouvelle feuille mais en laissant le classeur (archive) fermé. je cherche mais je ne trouve rien dans ce sens.
Si tu a encore une idée de genie, ce serais bien.
cordialement
Re le forum
Maguetlolo, pour écrire dans un classeur fermé
Sub EcritDatas()
Dim Fich$, cell As Range
Fich = "d:\TestAdo.xls" 'à adapter
'écrit dans le classeur fermé la valeur des cellules A1:A5
'du classeur actif
For Each cell In ActiveWorkbook.Sheets("Feuil1").Range("A1:A5")
SetExternalDatas Fich, "Feuil1", cell.Address(0, 0), cell.Text
Next
'écrit en A6 la date et l'heure de l'opération
SetExternalDatas Fich, "Feuil1", "A6", "mise à jour du " & Now
'on regarde le résultat
DoEvents
Workbooks.Open Fich
End Sub
'écrit DataToWrite dans la cellule DestCellAdr
'de la feuille DestFeuille du classeur fermé DestFile
Sub SetExternalDatas(DestFile As String, _
DestFeuille As String, _
DestCellAdr As String, _
DataToWrite As Variant)
Dim oConn As ADODB.Connection
Dim oCmd As ADODB.Command
Dim oRS As ADODB.Recordset
Dim RangeDest
'd'après Rob Bovey, mpep
' Open a connection to the Excel spreadsheet
Set oConn = New ADODB.Connection
oConn.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & DestFile & ";" & _
"Extended Properties=""Excel 8.0;HDR=No;"";"
' Create a command object and set its ActiveConnection
Set oCmd = New ADODB.Command
oCmd.ActiveConnection = oConn
' This SQL statement selects a cell range in the "feuilleTest" worksheet.
'1 Sélection pour écrire dans une seule cellule
RangeDest = DestCellAdr & ":" & DestCellAdr
oCmd.CommandText = "SELECT * from `" & DestFeuille & "$" & RangeDest & "`"
' Open a recordset containing the worksheet data.
Set oRS = New ADODB.Recordset
oRS.Open oCmd, , adOpenKeyset, adLockOptimistic
' Update last row
oRS(0).Value = DataToWrite
oRS.Update
'Close the connection
oConn.Close
Set oConn = Nothing
Set oCmd = Nothing
Set oRS = Nothing
End SubMytå
Re le forum
Maguetlolo, tu pourrais créer le fichier avec les feuilles à l'avance
Voilà un exemple de la création du fichier
Sub AddNewWorkbook()
Dim xlApp As Excel.Application
Dim xlBook As Excel.Workbook
Dim xlSheet As Excel.Worksheet
Dim Jour As Byte
'On créer l'objet Excel
Set xlApp = CreateObject("Excel.Application")
'On défini le nombre d'onglets (ici 31)
xlApp.SheetsInNewWorkbook = 31
'On ajoute un classeur
Set xlBook = xlApp.Workbooks.Add
'On donne un nom au classeur
xlBook.SaveAs ("Mon Classeur.xls")
'On rend le classeur visible
xlApp.Visible = True
For Jour = 1 To 31
'On créer l'objet onglet dans le nouveau classeur créé
Set xlSheet = xlBook.Worksheets(Jour)
'On affecte un nom aux l'onglets
xlSheet.Name = Jour
'on libère l'objet onglet pour pouvoir en créer un nouveau ... etc
Set xlSheet = Nothing
Next Jour
'On remet la propriété de l'application à 3 (par défaut)
xlApp.SheetsInNewWorkbook = 3
'On ferme l'application
xlApp.Quit
End SubMytå
Salut le forum
Maguetlolo, tu as maintenant le matériel pour t'amuser toute la fin de semaine
Attention aux nuits blanches, fais-toi un gros Silex de café
Mytå
Re;
Bonsoir Myta
Merci encore, je l'essaierais demain,
en attendant pour l'autre classeur, j'ai modifié ta macro (enfin rajouté pour la copie)et réussi a faire cela . ca a l'air de fonctionner, crois tu qu'il y a une facon plus facile d'ecrire la partie "copier/coller"? ou est ce que c'est bien comme ca?
Sub Tester()
Dim sNomFichier As String
sNomFichier = "C:\Users\maguetlolo\Desktop\" & "Archive_" & Format(Range("M2"), "mm") & "_" & Format(Range("M2"), "yyyy") & ".xls"
If ExistenceFichier(sNomFichier) Then
Range("A1:O65").Copy
Workbooks.Open Filename:="C:\Users\maguetlolo\Desktop\" & "Archive_" & Format(Range("M2"), "mm") & "_" & Format(Range("M2"), "yyyy") & ".xls"
Sheets.Add
ActiveSheet.Paste
ActiveSheet.Name = Range("B7").Value _
& " " & Format([m2], "yyyy") & Format([m2], "dd") & Format([m2], "mm") & " " & Range("C10").Value
MsgBox ("Le fichier existe")
Else
'Création du fichier avant la copie
MsgBox ("Le fichier n'existe pas")
Creation_Fichier
End If
Range("A1:O65").Copy
Workbooks.Open Filename:="C:\Users\maguetlolo\Desktop\" & "Archive_" & Format(Range("M2"), "mm") & "_" & Format(Range("M2"), "yyyy") & ".xls"
Sheets.Add
ActiveSheet.Paste
ActiveSheet.Name = Range("B7").Value _
& " " & Format([m2], "yyyy") & Format([m2], "dd") & Format([m2], "mm") & " " & Range("C10").Value
End Subcordialement
Re Maguetlolo et le forum
Essaye ceci, pas testé
Sub Tester()
Dim sNomFichier As String
sNomFichier = "C:\Archivages\" & "Archive_" & Format(Range("A1"), "mm") & "_" & Format(Range("A1"), "yyyy") & ".xls"
If Not ExistenceFichier(sNomFichier) Then
'Création du fichier
MsgBox ("Le fichier n'existe pas")
Creation_Fichier
End If
'On copie les données
MsgBox ("Le fichier existe")
Range("A1:O65").Copy
Workbooks.Open Filename:="C:\Users\maguetlolo\Desktop\" & "Archive_" & Format(Range("M2"), "mm") & "_" & Format(Range("M2"), "yyyy") & ".xls"
Sheets.Add
ActiveSheet.Paste
ActiveSheet.Name = Range("B7").Value _
& " " & Format([m2], "yyyy") & Format([m2], "dd") & Format([m2], "mm") & " " & Range("C10").Value
End SubMytå
re,
désolé, je n'ai pasvu tes deux message avant mareponse,
en fait le nom de la feuille depends de ce que contiendras les cellule, je ne peut donc pas les créer a l'avance
et pour les nuits blanches, ca ne serat pas la premiere fois
Bonsoir tout le monde
Voila, j'ai essayé de remanier le code afin que cela fonctionne comme je le veut.
seul problème (enfin j'espers) dans le cas ou le fichier d'archive n'existe pas, on lance
"Création_Fichier" afin de le creer puis on est sensé ajouter une feuille et coller comme lorsque le fichier existe deja. Mais je n'arrive pas a activer ce fichier creé et actuellement je colle dans le fichier d'origine.
J'ai essayé les "select" et les "activate" sans succés puisque je ne connais pas a l'avance le nom de ce fichier.
Si quelqu'un avais une idée ?
Function ExistenceFichier(sFichier As String) As Boolean
ExistenceFichier = Dir(sFichier) <> ""
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub Tester()
Dim sNomFichier As String
sNomFichier = "C:\Users\maguetlolo\Desktop\" & "Archive_" & Format(Range("M2"), "mm") & "_" & Format(Range("M2"), "yyyy") & ".xls"
If ExistenceFichier(sNomFichier) Then
MsgBox ("Le fichier existe")
Range("A1:O65").Copy
Workbooks.Open Filename:="C:\Users\Maguetlolo\Desktop\" & "Archive_" & Format(Range("M2"), "mm") & "_" & Format(Range("M2"), "yyyy") & ".xls"
End If
If Not ExistenceFichier(sNomFichier) Then
'Création du fichier
MsgBox ("Le fichier n'existe pas")
Range("A1:O65").Copy
Creation_Fichier
End If
'On copie les données
************************************************************************
[color=red]A cette endroit, Comment selectionner ou activer le classeur créé dans "Création_Fichier" (NomFichier = "C:\Users\maguetlolo\Desktop\" & "Archive_" & Format(Range("M2"), "mm") & "_" & Format(Range("M2"), "yyyy") & ".xls"
) pour que l'on puisse coller dedans au lieu de coller dans le fichier d'origine?[/color]
************************************************************************
Sheets.Add
ActiveSheet.Paste
ActiveSheet.Name = Range("B7").Value _
& " " & Format([m2], "yyyy") & Format([m2], "dd") & Format([m2], "mm") & " " & Range("C10").Value
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Sub Creation_Fichier()
'Activer la référence "Microsoft excel 11.0 object library"
Dim xlApp As New Excel.Application
Dim xlBook As Workbook
Dim NomFichier As String
Set xlApp = CreateObject("Excel.Application")
Set xlBook = xlApp.Workbooks.Add
xlApp.Visible = True
NomFichier = "C:\Users\maguetlolo\Desktop\" & "Archive_" & Format(Range("M2"), "mm") & "_" & Format(Range("M2"), "yyyy") & ".xls"
xlBook.SaveAs NomFichier
'xlBook.Close
'xlApp.Quit
Set xlBook = Nothing
Set xlApp = Nothing
End Subcordialement
Salut le forum
Maguetlolo, ton poste est en résolu.....
Tu penses avoir de l'aide, moi je ne crois pas....
Pas le temps de regarder ce soir désolé ...
Mytå
Bonsoir le monde
Apres plusieurs migraine, j'ai reussi ce que je voulais en incluant une ancienne macro
je joint le code pour info
Function ExistenceFichier(sFichier As String) As Boolean
ExistenceFichier = Dir(sFichier) <> ""
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub Tester()
Dim sNomFichier As String
Sheets("Feuil3").Select
sNomFichier = "C:\Users\maguetlolo\Desktop\" & "Archive_" & Format(Range("M2"), "mm") & "_" & Format(Range("M2"), "yyyy") & ".xls"
If ExistenceFichier(sNomFichier) Then
MsgBox ("Le fichier existe")
Range("A1:O65").Copy
Workbooks.Open Filename:="C:\Users\maguetlolo\Desktop\" & "Archive_" & Format (Range("M2"), "mm") & "_" & Format(Range("M2"), "yyyy") & ".xls"
'On copie les données
Sheets.Add
ActiveSheet.Paste
ActiveSheet.Name = Range("D7").Value _
& " " & Format([m2], "yyyy") & Format([m2], "dd") & Format([m2], "mm") & " " & Range("C10").Value
With ActiveWorkbook
.Save
.Close
End With
End If
If Not ExistenceFichier(sNomFichier) Then
'Création du fichier
MsgBox ("Le fichier n'existe pas")
'Creation_Fichier
Archiver
End If
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Sub Archiver()
Dim nomfichier
Dim num As Integer
Dim no_client As String
ThisWorkbook.ActiveSheet.Copy
Chemin = "C:\Users\maguetlolo\Desktop\"
nomfichier = "Archive_" & Format(Range("M2"), "mm") & "_" & Format(Range("M2"), "yyyy") & ".xls"
'MsgBox "Sauvegarde de la feuille en cours le : " & nomfichier
ActiveSheet.Name = Range("D7").Value _
& " " & Format([m2], "yyyy") & Format([m2], "dd") & Format([m2], "mm") & " " & Range("C10").Value
With ActiveWorkbook
.SaveAs Filename:=Chemin & nomfichier
.Close
End With
End SubJe passe au probleme d'apres pour le quel je ne sait pas comment faire.
comment puis-je faire dans le cas ou le classeur existe pour vérifier si le nom de la nouvelle feuille existe deja et dans ce cas remplacer l'ancienne par la nouvelle?
Cordialement
Bonsoir tout lemonde
un dernier message et je mets résolu
j'ai trouvé la reponse a ma derniere question en cherchant sur google, je n'avais plus qu'a l'inserer dans mes codes:
Function FeuilleExiste(wk As Workbook, stFeuille) As Boolean
On Error Resume Next
FeuilleExiste = Not (wk.Sheets(stFeuille) Is Nothing)
End Function
Sub MonTestDelaFonctionExiste()
If FeuilleExiste(ThisWorkbook, "feuil1") Then
MsgBox "la feuille existe"
Else
MsgBox "N'existe pas "
End If
End SubMerci Myta pour ton aide.
Cordialement
Bonsoir tout lemonde
un dernier message et je mets résolu
j'ai trouvé la reponse a ma derniere question en cherchant sur google, je n'avais plus qu'a l'inserer dans mes codes:
Function FeuilleExiste(wk As Workbook, stFeuille) As Boolean
On Error Resume Next
FeuilleExiste = Not (wk.Sheets(stFeuille) Is Nothing)
End Function
Sub MonTestDelaFonctionExiste()
If FeuilleExiste(ThisWorkbook, "feuil1") Then
MsgBox "la feuille existe"
Else
MsgBox "N'existe pas "
End If
End SubMerci Myta pour ton aide.
Cordialement