Archivage Auto

Y compris Power BI, Power Query et toute autre question en lien avec Excel
A
Ahah
Jeune membre
Jeune membre
Messages : 20
Inscrit le : 5 décembre 2017
Version d'Excel : 2010 FR

Message par Ahah » 5 décembre 2017, 12:09

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é!
Gestion des chgts d'emballage V2.xlsb
(100.72 Kio) Téléchargé 29 fois
Avatar du membre
GVIALLES
Membre dévoué
Membre dévoué
Messages : 823
Appréciations reçues : 74
Inscrit le : 28 novembre 2017
Version d'Excel : 2016, 360
Téléchargements : Mes applications

Message par GVIALLES » 8 décembre 2017, 17:43

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
Cordialement,

Gérard
A
Ahah
Jeune membre
Jeune membre
Messages : 20
Inscrit le : 5 décembre 2017
Version d'Excel : 2010 FR

Message par Ahah » 11 décembre 2017, 14:26

Bonjour Gvialles,

Je vous remercie beaucoup pour l'aide apporté.
Votre code fonctionne à la perfection!!
Vous avez répondu à mon besoin!

Merci à vous,

Guillaume
A
Ahah
Jeune membre
Jeune membre
Messages : 20
Inscrit le : 5 décembre 2017
Version d'Excel : 2010 FR

Message par Ahah » 11 décembre 2017, 15:26

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!
Avatar du membre
GVIALLES
Membre dévoué
Membre dévoué
Messages : 823
Appréciations reçues : 74
Inscrit le : 28 novembre 2017
Version d'Excel : 2016, 360
Téléchargements : Mes applications

Message par GVIALLES » 12 décembre 2017, 11:06

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
Cordialement,

Gérard
A
Ahah
Jeune membre
Jeune membre
Messages : 20
Inscrit le : 5 décembre 2017
Version d'Excel : 2010 FR

Message par Ahah » 12 décembre 2017, 12:22

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!
Avatar du membre
GVIALLES
Membre dévoué
Membre dévoué
Messages : 823
Appréciations reçues : 74
Inscrit le : 28 novembre 2017
Version d'Excel : 2016, 360
Téléchargements : Mes applications

Message par GVIALLES » 12 décembre 2017, 14:38

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
Cordialement,

Gérard
A
Ahah
Jeune membre
Jeune membre
Messages : 20
Inscrit le : 5 décembre 2017
Version d'Excel : 2010 FR

Message par Ahah » 12 décembre 2017, 16:11

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...
champ_recherche.xls
(48 Kio) Téléchargé 12 fois
Avatar du membre
GVIALLES
Membre dévoué
Membre dévoué
Messages : 823
Appréciations reçues : 74
Inscrit le : 28 novembre 2017
Version d'Excel : 2016, 360
Téléchargements : Mes applications

Message par GVIALLES » 12 décembre 2017, 17:03

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
Cordialement,

Gérard
A
Ahah
Jeune membre
Jeune membre
Messages : 20
Inscrit le : 5 décembre 2017
Version d'Excel : 2010 FR

Message par Ahah » 8 janvier 2018, 11:46

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!!
Répondre
  • Sujets similaires
    Réponses
    Vues
    Dernier message