Bonjour,
Je souhaite regrouper 4 macros en 1 seule.
Pouvez-vous m'aider svp ?
Option Explicit
Sub emplacement()
'Sélection Répertoire et sous répertoire à nettoyer
Dim chemin As String 'variable
'
With Application.FileDialog(msoFileDialogFolderPicker)
'Définit un titre pour la boîte de dialogue
.Title = "Sélectionner un lecteur et un dossier svp !"
.Show
If .SelectedItems.Count > 0 Then
chemin = .SelectedItems(1) & "\"
[a1] = chemin 'Saisie chemin pour suite...
End If
End With
End Sub
Sub FiltreDate()
'Filtre fichiers non concernés par le nettoyage
Dim DateLimite As Long 'variable
'
DateLimite = Range("G2").Value
ActiveSheet.Range("$A$3:$d$5000").AutoFilter Field:=4, Criteria1:=">" & DateLimite
End Sub
Sub DeleteRowsAutofiltered()
'Suite au filtre précédent, suppression des lignes à ne pas traiter
Dim Ws As Worksheet 'variable Nom de la feuille
Dim Nblg As Long 'variable Nombre de lignes
Dim oRange As Range 'variable cellule
'
Set Ws = ThisWorkbook.Sheets("BD") 'indication Feuille de travail
Set oRange = Ws.Range(Ws.Rows(4), Ws.Rows(Ws.UsedRange.Rows.Count)) 'Compteur filtre colonne4 = Colonne D
'on teste pour savoir si un filtre est actif et dans ce cas, on supprime les lignes filtrées
If oRange.SpecialCells(xlCellTypeVisible).Rows.Count < oRange.Rows.Count Then
oRange.SpecialCells(xlCellTypeVisible).EntireRow.Delete
End If
'On fait le ménage
Set Ws = Nothing
Set oRange = Nothing
ActiveSheet.Range("$A$3:$D$5000").AutoFilter Field:=4
End Sub
Sub SuppressionFichiers_anciens()
'Suppression fichiers trop anciens
Dim chemin As String, Fichier As String, x As Long, Ouvert As Long, c As Range, Msg As String 'variables
'
chemin = [a1].Value ' cellule ou se trouve le chemin Cellule A1
For Each c In Range("a4:a" & Cells(Rows.Count, "A").End(xlUp).Row) 'fichiers indiqués à partir de la ligne 4 colonne A
Fichier = Dir(chemin & c.Value) 'Eléments nécessaires pour Supprimer fichiers trop anciens ( Chemin et Nom fichier)
On Error Resume Next 'Si erreur, suivant
Kill chemin & Fichier 'Suppression fichiers
If Err = 0 Then x = x + 1
Fichier = Dir
On Error GoTo 0
Next
Msg = "Terminé " 'Mesage Fin
Msg = Msg & vbLf & x & IIf(x > 1, " Fichiers supprimés", " Fichier supprimé") 'Message Fin Nombre de fichiers supprimés
MsgBox Msg, , "Information."
End Sub
Merci d'avance !
Je souhaite regrouper 4 macros en 1 seule.
Pouvez-vous m'aider svp ?
Option Explicit
Sub emplacement()
'Sélection Répertoire et sous répertoire à nettoyer
Dim chemin As String 'variable
'
With Application.FileDialog(msoFileDialogFolderPicker)
'Définit un titre pour la boîte de dialogue
.Title = "Sélectionner un lecteur et un dossier svp !"
.Show
If .SelectedItems.Count > 0 Then
chemin = .SelectedItems(1) & "\"
[a1] = chemin 'Saisie chemin pour suite...
End If
End With
End Sub
Sub FiltreDate()
'Filtre fichiers non concernés par le nettoyage
Dim DateLimite As Long 'variable
'
DateLimite = Range("G2").Value
ActiveSheet.Range("$A$3:$d$5000").AutoFilter Field:=4, Criteria1:=">" & DateLimite
End Sub
Sub DeleteRowsAutofiltered()
'Suite au filtre précédent, suppression des lignes à ne pas traiter
Dim Ws As Worksheet 'variable Nom de la feuille
Dim Nblg As Long 'variable Nombre de lignes
Dim oRange As Range 'variable cellule
'
Set Ws = ThisWorkbook.Sheets("BD") 'indication Feuille de travail
Set oRange = Ws.Range(Ws.Rows(4), Ws.Rows(Ws.UsedRange.Rows.Count)) 'Compteur filtre colonne4 = Colonne D
'on teste pour savoir si un filtre est actif et dans ce cas, on supprime les lignes filtrées
If oRange.SpecialCells(xlCellTypeVisible).Rows.Count < oRange.Rows.Count Then
oRange.SpecialCells(xlCellTypeVisible).EntireRow.Delete
End If
'On fait le ménage
Set Ws = Nothing
Set oRange = Nothing
ActiveSheet.Range("$A$3:$D$5000").AutoFilter Field:=4
End Sub
Sub SuppressionFichiers_anciens()
'Suppression fichiers trop anciens
Dim chemin As String, Fichier As String, x As Long, Ouvert As Long, c As Range, Msg As String 'variables
'
chemin = [a1].Value ' cellule ou se trouve le chemin Cellule A1
For Each c In Range("a4:a" & Cells(Rows.Count, "A").End(xlUp).Row) 'fichiers indiqués à partir de la ligne 4 colonne A
Fichier = Dir(chemin & c.Value) 'Eléments nécessaires pour Supprimer fichiers trop anciens ( Chemin et Nom fichier)
On Error Resume Next 'Si erreur, suivant
Kill chemin & Fichier 'Suppression fichiers
If Err = 0 Then x = x + 1
Fichier = Dir
On Error GoTo 0
Next
Msg = "Terminé " 'Mesage Fin
Msg = Msg & vbLf & x & IIf(x > 1, " Fichiers supprimés", " Fichier supprimé") 'Message Fin Nombre de fichiers supprimés
MsgBox Msg, , "Information."
End Sub
Merci d'avance !
)
