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...
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