Archivage Auto

Bonjour,

Je fais appel à vous pour un fichier dans lequel j'aimerai pouvoir :

1) Archiver les lignes où il est écrit dans la cellule G : "Archiver" (ex : dans le ficheir, archiver de la ligne A4 à E10)

2) Archiver en mode "image", c'est à dire sans liaison

3) Archiver les lignes dans la feuille Archivage, les unes à la suite des autres

3) Supprimer les lignes lorsque celles-ci sont archivées

Tout cela de manière automatique en cliquant sur le dossier d'archive!

Merci à vous et à votre solidarité!

Bonsoir Ahah

Si ton pb est toujours d'actualité, voici ma proposition :

Public Sub Archive_GVS()
    'Pour plus de souplesse, on déclare les valeurs utiles en début de module
    Const cFirstRow = 4
    Const cNbRows = 7
    Const cFirstCol = 1
    Const cLastCol = 6
    Const cColEtat = 7
    Const cArchiver = "Archiver"

    Dim oSheetIN As Excel.Worksheet
    Dim oSheetOUT As Excel.Worksheet
    Dim oRangeIN As Excel.Range, oCellOUT As Excel.Range, oRange As Excel.Range
    Dim lRowArchivage As Long

    Set oSheetIN = ThisWorkbook.Worksheets("Info fin de semaine")
    Set oSheetOUT = ThisWorkbook.Worksheets("Archivage")

    For Each oRangeIN In oSheetIN.UsedRange.Columns(cColEtat).Rows 'On parcourt la colonne "Etat" de la feuille "Info fin de semaine" pour sélectionner les "ARCHIVER"
        If oRangeIN.Value2 = cArchiver Then
            Set oRange = oSheetIN.Range(oSheetIN.Cells(oRangeIN.Row, cFirstCol), oSheetIN.Cells(oRangeIN.Row + cNbRows - 1, cLastCol))
            lRowArchivage = searchInsertRow(oSheetOUT) 'On recherche la cellule d'insertion dans la feuille "Archivage"
            oRange.Cut oSheetOUT.Cells(lRowArchivage, 1) 'On Copie/Colle
            Set oRange = oSheetIN.Range(oSheetIN.Rows(oRangeIN.Row), oSheetIN.Rows(oRangeIN.Row + cNbRows - 1))
            oRange.Delete 'On supprime les lignes
        End If
    Next

    'On fait le ménage...
    Set oSheetIN = Nothing
    Set oSheetOUT = Nothing
    Set oRangeIN = Nothing
    Set oRange = Nothing

End Sub
Function searchInsertRow(zSheetOUT As Excel.Worksheet) As Long
    Const cFirstRow = 3
    Const cNbRows = 7

    Dim oRange As Excel.Range
    Dim lLastRow As Long, lInsertRow As Long
    Dim i As Long

    lLastRow = zSheetOUT.UsedRange.Rows.Count

    For i = cFirstRow To lLastRow Step cNbRows
        Set oRange = zSheetOUT.Cells(i, 3)
        If Len(oRange.Value & "") = 0 Then
            lInsertRow = oRange.Row
            Exit For
        End If
    Next

    If lInsertRow > 0 Then
        searchInsertRow = lInsertRow
    Else
        searchInsertRow = lLastRow + 1
    End If

End Function

Pour une exécution lorsque l'onglet "Archivage" est sélectionné, il te faut ajouter dans le module attaché à la feuille :

Private Sub Worksheet_Activate()
    Archive_GVS
End Sub

Bonjour Gvialles,

Je vous remercie beaucoup pour l'aide apporté.

Votre code fonctionne à la perfection!!

Vous avez répondu à mon besoin!

Merci à vous,

Guillaume

Gvialles,

Auriez-vous un code Macro afin d'ajouter automatiquement des lignes à la suite dans l'onglet "Info fin de semaine", et ce avec la même mise en forme?

Car à force d'archiver des lignes et de les supprimer, je n'aurai plus de formulaire (un formulaire = 7 lignes, de la colonne A à G).

Merci pour votre précieuse aide!

Bonjour Guillaume,

Ma proposition de macro pour ajouter des lignes :

Sub addInfos()
    Dim oRangeOrg As Excel.Range, oRangeDest As Excel.Range, oCell As Excel.Range
    Dim oSheet As Excel.Worksheet
    Dim lLastRow As Long

    Set oSheet = ThisWorkbook.Worksheets("Info fin de semaine")
    lLastRow = oSheet.UsedRange.Rows.Count

    Set oRangeOrg = oSheet.Range(oSheet.Rows(4), oSheet.Rows(10))
    Set oRangeDest = oSheet.Cells(lLastRow + 1, 1)
    oRangeOrg.Copy oRangeDest

    Set oRangeDest = oSheet.Range(oSheet.Cells(lLastRow + 1, 2), oSheet.Cells(lLastRow + 7, 2))

    For Each oCell In oRangeDest.Cells
        oCell.Activate
        oCell.Value2 = ActiveCell.Offset(-7, 0).Value2
    Next

    Set oRangeOrg = Nothing
    Set oRangeDest = Nothing
    Set oCell = Nothing
End Sub

Bonjour Gvialles,

Votre macro répond à mon besoin pour ajouter un nouveau formulaire!

Néanmoins, elle n'efface pas les données dans le nouveau formulaire!

C'est à dire que la colonne C ainsi que les 3 dernières lignes du nouveau formulaire doivent être vierges pour inscrire manuellement de nouvelles données.

Est-il envisageable d'ajouter un code pour "faire le ménage" dans ces cellules?

Vous m'apportez une grande aide Gérard, je vous en remercie!

Guillaume,

Version avec effacement des données :

Sub addInfos()
    Dim oRangeOrg As Excel.Range, oRangeDest As Excel.Range, oCell As Excel.Range
    Dim oSheet As Excel.Worksheet
    Dim lLastRow As Long

    Set oSheet = ThisWorkbook.Worksheets("Info fin de semaine")
    lLastRow = oSheet.UsedRange.Rows.Count

    Set oRangeOrg = oSheet.Range(oSheet.Rows(4), oSheet.Rows(10))
    Set oRangeDest = oSheet.Cells(lLastRow + 1, 1)
    oRangeOrg.Copy oRangeDest

    Set oRangeDest = oSheet.Range(oSheet.Cells(lLastRow + 1, 1), oSheet.Cells(lLastRow + 7, 7))
    oRangeDest.ClearContents

    For Each oCell In oRangeDest.Cells
        oCell.Activate
        oCell.Value2 = ActiveCell.Offset(-7, 0).Value2
    Next

    Set oRangeDest = oSheet.Range(oSheet.Cells(lLastRow + 1, 2), oSheet.Cells(lLastRow + 7, 2))

    For Each oCell In oRangeDest.Cells
        oCell.Activate
        oCell.Value2 = ActiveCell.Offset(-7, 0).Value2
    Next

    Set oRangeOrg = Nothing
    Set oRangeDest = Nothing
    Set oCell = Nothing
End Sub

Encore une fois merci pour la réactivité et la qualité des solutions apportées!

Le fichier est solide!

Avez-vous sous le coude une Macro permettant de rechercher une valeur numérique de la colonne C afin de savoir si le formulaire pour cette valeur a déjà était rempli ?

L'idée que je m'en fait ressemble au fichier joint, mais je n'ai pas trouvé la macro associé... ni même le type de bouton à insérer...

15champ-recherche.zip (15.99 Ko)

Guillaume,

Le code que tu cherches :

Private Sub TextBox1_Change()

    Application.ScreenUpdating = False

    Range("A2:A24").Interior.ColorIndex = 2
    ListBox1.Clear

    If TextBox1 <> "" Then
        For ligne = 2 To 24
            If Cells(ligne, 1) Like "*" & TextBox1 & "*" Then
                Cells(ligne, 1).Interior.ColorIndex = 43
                ListBox1.AddItem Cells(ligne, 1)
            End If
        Next
    End If

End Sub

Pour qu'il fonctionne, il faut que tu créés quelque part sur la feuille

- une textbox nommée TextBox1 :

=INCORPORER("Forms.TextBox.1";"")

- une listbox nommée ListBox1

=INCORPORER("Forms.ListBox.1";"")

Et que tu modifie la plage : dans la macro A2:A24

Bonjour et bonne année à tous,

Pouvez vous m'aider sur un point de blocage.

J'aimerai créer une macro qui permettrait d'enregistrer le fichier sous le format PDF en reprenant la valeur de la cellule D2.

Nom du fichier : "Gestion des changements d'emballage - Cellule D2.pdf".

L'emplacement de sauvegarde : U:\archivages

Merci de votre aide!!

Guillaume,

Ci-dessous la macro d'impression PDF de la feuille active.

Tu dois, au préalable, nommer la cellule D2 ainsi : "NomPDF" . Pour ce faire, tu sélectionnes D2 puis tu sélectionnes dans le menu EXCEL "Formules/Définir un nom" puis tu tapes "NomPDF" dans la boîte de dialogue et OK.

Sub SavePDF()
    Const cPath = "U:\Archivages"
    Const cPrefix = "Gestion des changements d'emballage -"

    Dim sFilename As String
    Dim oCell As Excel.Range

    Set oCell = ThisWorkbook.Names("NomPDF").RefersToRange

    sFilename = cPath & "\" & cPrefix & oCell.Value & ".pdf"

    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
        sFilename, OpenAfterPublish:=False

    Set oCell = Nothing
End Sub
Rechercher des sujets similaires à "archivage auto"