Archiver automatiquement

Bonjour,

voila je cherche a archiver dans feuil du nom de la colonne B si G et H sont rempli, de plus si la feuil n'existe pas la créer

merci d'avance

Bonsoir,

une proposition de modification de la macro existante.

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Count > 1 Then Exit Sub
    If Not Intersect(Target, Range("G2:G" & Range("G" & Rows.Count).End(xlUp).Row)) Is Nothing Then
        i = Target.Row
        Set wst = Worksheets("travaux")
        wse = True
        On Error GoTo terreur
        feuil = wst.Range("B" & i)
        Set wsa = Worksheets(feuil)
        On Error GoTo 0
        If wse = False Then
            Worksheets("archive").Copy after:=Worksheets(Worksheets.Count)
            Set wsa = Worksheets(Worksheets.Count)
            wsa.Name = wst.Range("B" & i)
        End If
        dla = wsa.Range("a" & Rows.Count).Row
        wst.Rows(i).Copy wsa.Range("A" & dla)
        wst.Rows(i).Delete shift:=xlUp
    End If
    Exit Sub
terreur:
    wse = False
    Resume Next
End Sub

Merci deja pour l'aide

bon pour le moment ça crée la feuille par contre il copie a la ligne 65536 la selection et lorsqu'il y en a une autre il recopie dessus

et ausi je souhaite selectionner les deux colonne

bonsoir,

désolé, je dois être fatigué

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Count > 1 Then Exit Sub
    If Not Intersect(Target, Range("G2:G" & Range("G" & Rows.Count).End(xlUp).Row)) Is Nothing Then
        i = Target.Row
        Set wst = Worksheets("travaux")
        wse = True
        On Error GoTo terreur
        feuil = wst.Range("B" & i)
        Set wsa = Worksheets(feuil)
        On Error GoTo 0
        If wse = False Then
            Worksheets("archive").Copy after:=Worksheets(Worksheets.Count)
            Set wsa = Worksheets(Worksheets.Count)
            wsa.Name = wst.Range("B" & i)
        End If
        dla = wsa.Range("a" & Rows.Count).End(xlUp).Row + 1
        wst.Rows(i).Copy wsa.Range("A" & dla)
        wst.Rows(i).Delete shift:=xlUp
    End If
    Exit Sub
terreur:
    wse = False
    Resume Next
End Sub

bon la c'est presque bon mais il copie trois ligne, apres le fait de remplir que la colonne G il archive automatiquement alors qu il faut G et H

comme ça apres j'essaye de comprendre le programme pour l'adapté

merci encore

Private Sub Worksheet_Change(ByVal Target As Range)
' si plus d'une cellule modifiée on sort
    If Target.Count > 1 Then Exit Sub
' on regarde si la modification a eu lieu en colonne G ou H
    If Not Intersect(Target, Range("G2:H" & Range("G" & Rows.Count).End(xlUp).Row)) Is Nothing Then

        i = Target.Row ' i contient le numero de la ligne modifiée
        If Range("G" & i) <> "" And Range("H" & i) <> "" Then ' si les colonnes G et H de la lignes sont remplies
        Set wst = Worksheets("travaux") ' wst référence la feuille "travaux"
        wse = True ' wse indique si la feuille où archiver existe
        On Error GoTo terreur ' on arme le traitement d'erreur
        feuil = wst.Range("B" & i) ' feuil contient le nom de la feuille archive pour cette ligne
        Set wsa = Worksheets(feuil) ' wsa référece la feuille archive (si elle existe, sinon il traitement d'erreur)
        On Error GoTo 0 ' on réarme le traitement d'erreur standard si erreur on va à Terreur 
        If wse = False Then ' si la feuille archive n'existe pas
            Worksheets("archive").Copy after:=Worksheets(Worksheets.Count) ' on la crée sur base d'une copie de la feuille "archive"
            Set wsa = Worksheets(Worksheets.Count) ' wsa référence cette copie
            wsa.Name = wst.Range("B" & i) ' on renomme la copie
        End If
        dla = wsa.Range("a" & Rows.Count).End(xlUp).Row + 1 ' dla = 1ere ligne libre sur wsa
        wst.Rows(i).Copy wsa.Range("A" & dla) ' on copie la ligne de wst dans wsa
        wst.Rows(i).Delete shift:=xlUp ' on supprime la ligne de wst
        End If
    End If
    Exit Sub
terreur: ' traitement d'erreur, on arrive ici si feuille n'existe pas
    wse = False ' on indique que la feuille n'exsite pas 
    Resume Next ' on reprend le programme à l'instruction qui suit  celle qui a provoqué l'erreur
End Sub

impecable ça fonctionne il me reste plus qu'a adapter cela a mon classeur

encore merci a tous

j'ai mis des commentaires dans le code.

Merci encore je d'informer si je bloque quelque part

Maintenant si je veux enregistrer sur un nouveau classeur et pas sur une feuille comme sur l.exemple que tu a fait dans le même répertoire et controler biensur qu'il existe si pas le creer.

Et si possible sur la feuille du classeur actuel enregistrer le nom du classeur.

Le classeur à creer doit reprendre aussi le nom de la colonne comme sur l'exemple

bonsoir,

voici le code adapté

Private Sub Worksheet_Change(ByVal Target As Range)
' si plus d'une cellule modifiée on sort
   If Target.Count > 1 Then Exit Sub
' on regarde si la modification a eu lieu en colonne G ou H
   If Not Intersect(Target, Range("G2:H" & Range("G" & Rows.Count).End(xlUp).Row)) Is Nothing Then

        i = Target.Row ' i contient le numero de la ligne modifiée
       If Range("G" & i) <> "" And Range("H" & i) <> "" Then ' si les colonnes G et H de la lignes sont remplies
       Set twb = ThisWorkbook
       Set wst = twb.Worksheets("travaux") ' wst référence la feuille "travaux"
       Path = twb.Path
       If Path <> "" Then Path = Path & "\"
       feuil = wst.Range("B" & i)
       f = Dir(Path & feuil & ".xls") ' verifie si fichier existe
       If f = "" Then ' fichier n'existe pas
       Set wba = Workbooks.Add 'on le crée
       Else 'il existe
       Set wba = Workbooks.Open(Path & feuil & ".xls") 'on l'ouvre
       wba.SaveAs Path & feuil & ".xls" ' on sauve l'archive
       End If
       wse = True ' wse indique si la feuille où archiver existe
       On Error GoTo terreur ' on arme le traitement d'erreur
        ' feuil contient le nom de la feuille archive pour cette ligne
       Set wsa = wba.Worksheets(feuil) ' wsa référece la feuille archive (si elle existe, sinon il traitement d'erreur)
       On Error GoTo 0 ' on réarme le traitement d'erreur standard si erreur on va à Terreur
       If wse = False Then ' si la feuille archive n'existe pas
           twb.Worksheets("archive").Copy after:=wba.Worksheets(wba.Worksheets.Count) ' on la crée sur base d'une copie de la feuille "archive"
           Set wsa = wba.Worksheets(Worksheets.Count) ' wsa référence cette copie
           wsa.Name = wst.Range("B" & i) ' on renomme la copie
       End If
        dla = wsa.Range("a" & Rows.Count).End(xlUp).Row + 1 ' dla = 1ere ligne libre sur wsa
       wst.Rows(i).Copy wsa.Range("A" & dla) ' on copie la ligne de wst dans wsa
       wst.Rows(i).Delete shift:=xlUp ' on supprime la ligne de wst
       wba.Save
       End If
    End If
    Exit Sub
terreur: ' traitement d'erreur, on arrive ici si feuille n'existe pas
   wse = False ' on indique que la feuille n'exsite pas
   Resume Next ' on reprend le programme à l'instruction qui suit  celle qui a provoqué l'erreur
End Sub

ça fonctionne impeccable mais est il possible d annuler le message qui demande si on souhaite remplacer le fichier déjà existant .

encore une fois merci

bonsoir,

code adapté à tester

Private Sub Worksheet_Change(ByVal Target As Range)
' si plus d'une cellule modifiée on sort
  If Target.Count > 1 Then Exit Sub
' on regarde si la modification a eu lieu en colonne G ou H
  If Not Intersect(Target, Range("G2:H" & Range("G" & Rows.Count).End(xlUp).Row)) Is Nothing Then

        i = Target.Row ' i contient le numero de la ligne modifiée
      If Range("G" & i) <> "" And Range("H" & i) <> "" Then ' si les colonnes G et H de la lignes sont remplies
      Set twb = ThisWorkbook
       Set wst = twb.Worksheets("travaux") ' wst référence la feuille "travaux"
      Path = twb.Path
       If Path <> "" Then Path = Path & "\"
       feuil = wst.Range("B" & i)
       f = Dir(Path & feuil & ".xls") ' verifie si fichier existe
      If f = "" Then ' fichier n'existe pas
      Set wba = Workbooks.Add 'on le crée
      Else 'il existe
      Set wba = Workbooks.Open(Path & feuil & ".xls") 'on l'ouvre
      wba.SaveAs Path & feuil & ".xls" ' on sauve l'archive
      End If
       wse = True ' wse indique si la feuille où archiver existe
      On Error GoTo terreur ' on arme le traitement d'erreur
       ' feuil contient le nom de la feuille archive pour cette ligne
      Set wsa = wba.Worksheets(feuil) ' wsa référece la feuille archive (si elle existe, sinon il traitement d'erreur)
      On Error GoTo 0 ' on réarme le traitement d'erreur standard si erreur on va à Terreur
      If wse = False Then ' si la feuille archive n'existe pas
          twb.Worksheets("archive").Copy after:=wba.Worksheets(wba.Worksheets.Count) ' on la crée sur base d'une copie de la feuille "archive"
          Set wsa = wba.Worksheets(Worksheets.Count) ' wsa référence cette copie
          wsa.Name = wst.Range("B" & i) ' on renomme la copie
      End If
        dla = wsa.Range("a" & Rows.Count).End(xlUp).Row + 1 ' dla = 1ere ligne libre sur wsa
      wst.Rows(i).Copy wsa.Range("A" & dla) ' on copie la ligne de wst dans wsa
      wst.Rows(i).Delete shift:=xlUp ' on supprime la ligne de wst
      wba.Save
       End If
    End If
    Exit Sub
terreur: ' traitement d'erreur, on arrive ici si feuille n'existe pas
  wse = False ' on indique que la feuille n'exsite pas
  Resume Next ' on reprend le programme à l'instruction qui suit  celle qui a provoqué l'erreur
End Sub

Merci encore

je test demain car la je vais bouger un peu

petite question comment on change le non de référence pour l’enregistrement

la il prend la colonne B et si je veux changer et prendre par exemple la D ou C et D

cisco38 a écrit :

Merci encore

je test demain car la je vais bouger un peu

petite question comment on change le non de référence pour l’enregistrement

la il prend la colonne B et si je veux changer et prendre par exemple la D ou C et D

il faut remplacer le B dans l'instruction suivante

feuil = wst.Range("B" & i)

C' est encore tout bon et si je veux enregistrer sous C et D

par exemple dans colonne C le repertoire et colonne D le non du classeur

demain je finalise et je t'envoie mon projet complet

merci encore

voila mon projet est quasiment fini

j'ai rajouté un calendrier avec clic sur cellule ,renvoie des cellules pour création fiche et modification pour fermeture de la fiche créer après la sauvegarde

comme d'habitude on veux toujours rajouter des choses

par exemple est il possible de copier dans un nouveau répertoire s'il n'existe pas qui a la valeur de C et après le ficher excel

et archiver en même temps sur onglet planche la nouvelle fiche

bonsoir,

adapté,

merci encore

je regarde comment c'est fait pour l'adapter et surtout comprendre pour plus tard

je dois l'adapter sur celui ci

https://forum.excel-pratique.com/excel/aide-pour-projet-t49086.html

bonjour,

je viens de remarquer un petit bug

lorsque je valide une tache il ouvre bien la fiche correspondante mais il n'enregistre pas la nouvelle tache en dessous de celle déjà en place.il efface celle deja en place

de plus si une fiche existe déjà il en créer quand même une autre dans le suivi planche

peut on mettre une condition du genre si le local et la planche existe ne pas creer, mais laisser la possiblilte de creer une planche dans un autre local