Macro pour supprimer un fichier excel Le sujet est résolu

Y compris Power BI, Power Query et toute autre question en lien avec Excel
h
h2so4
Passionné d'Excel
Passionné d'Excel
Messages : 8'617
Appréciations reçues : 297
Inscrit le : 16 juin 2013
Version d'Excel : 2013 UK Windows 10

Message par h2so4 » 13 septembre 2017, 15:43

bonjour,

une proposition
Sub aargh()
    rep = "d:\"    ' répertoire à examiner
    kfif rep, "essai.xlsm"
End Sub

Sub kfif(folder, filtre)

    Set fold = CreateObject("Scripting.FileSystemObject").GetFolder(folder)
    For Each f In fold.SubFolders
        If Right(f, 1) <> "\" Then kfif f & "\", filtre Else kfif f, filtre
    Next
    For Each f In fold.Files
        If InStr(f, filtre) <> 0 Then
            r = MsgBox("supprimer" & f & " OK ?", vbYesNo)
            If r = vbYes Then Kill f
        End If
    Next
End Sub
s
stepaustras
Membre fidèle
Membre fidèle
Messages : 197
Appréciations reçues : 2
Inscrit le : 12 mai 2015
Version d'Excel : 2007

Message par stepaustras » 13 septembre 2017, 16:07

Merci h2s04,
La macro fonctionne, j'ai mis ça
rep = "C:\Users\Stef\Nouveau dossier\"


Mais avec C:\Users ça marche pas

Et donc j'obtiens l'erreur a cette ligne pour rep = "c:\Users\"
For Each F In fold.SubFolders
Même si je met d:\ ou e:\ vu que j'ai plusieurs disque même erreur a for Each....
h
h2so4
Passionné d'Excel
Passionné d'Excel
Messages : 8'617
Appréciations reçues : 297
Inscrit le : 16 juin 2013
Version d'Excel : 2013 UK Windows 10

Message par h2so4 » 13 septembre 2017, 16:25

bonjour,

essaie si cette correction fonctionne
Sub aargh()
    rep = "i:\"    ' répertoire à examiner
    kfif rep, "essai.xlsm"
End Sub

Sub kfif(folder, filtre)

    Set fold = CreateObject("Scripting.FileSystemObject").GetFolder(folder)
    On Error Resume Next
    For Each f In fold.SubFolders
        If Not Err Then
            Application.StatusBar = f
            If Right(f, 1) <> "\" Then kfif f & "\", filtre Else kfif f, filtre
        Else
            MsgBox "erreur " & Err
            Err.Clear
        End If
    Next
    For Each f In fold.Files
        If InStr(f, filtre) <> 0 Then
            r = MsgBox("supprimer" & f & " OK ?", vbYesNo)
            If r = vbYes Then Kill f
        End If
    Next
End Sub
s
stepaustras
Membre fidèle
Membre fidèle
Messages : 197
Appréciations reçues : 2
Inscrit le : 12 mai 2015
Version d'Excel : 2007

Message par stepaustras » 13 septembre 2017, 16:30

Merci ça l'air de fonctionner il met boite de dialogue quand il trouve supprime le fichier concerné et continue son scan sur tous C: alors que je lui demande que C:\Users\ ? En faite il scan tous C:
Sub aargh()
    rep = "c:\Users\"    ' répertoire à examiner
   kfif rep, "essai.xlsm"
End Sub

Sub kfif(folder, filtre)

    Set fold = CreateObject("Scripting.FileSystemObject").GetFolder(folder)
    On Error Resume Next
    For Each F In fold.SubFolders
        If Not Err Then
            Application.StatusBar = F
            If Right(F, 1) <> "\" Then kfif F & "\", filtre Else kfif F, filtre
        Else
            MsgBox "erreur " & Err
            Err.Clear
        End If
    Next
    For Each F In fold.Files
        If InStr(F, filtre) <> 0 Then
            r = MsgBox("supprimer" & F & " OK ?", vbYesNo)
            If r = vbYes Then Kill F
        End If
    Next
End Sub
h
h2so4
Passionné d'Excel
Passionné d'Excel
Messages : 8'617
Appréciations reçues : 297
Inscrit le : 16 juin 2013
Version d'Excel : 2013 UK Windows 10

Message par h2so4 » 13 septembre 2017, 17:16

bonjour,

apparemment un problème dans la gestion des erreurs;

essaie ceci
Sub aargh()
    rep = "c:\users"    ' répertoire à examiner
    kfif rep, "essai.xlsm"
End Sub

Sub kfif(folder, filtre)

    Set fold = CreateObject("Scripting.FileSystemObject").GetFolder(folder)
    On Error GoTo terr
    For Each f In fold.SubFolders
            Application.StatusBar = f
            If Right(f, 1) <> "\" Then kfif f & "\", filtre Else kfif f, filtre

    Next

    For Each f In fold.Files
        If InStr(f, filtre) <> 0 Then
            r = MsgBox("supprimer" & f & " OK ?", vbYesNo)
            If r = vbYes Then Kill f
        End If
    Next
ici:
    Exit Sub
terr:
    Resume ici
End Sub
s
stepaustras
Membre fidèle
Membre fidèle
Messages : 197
Appréciations reçues : 2
Inscrit le : 12 mai 2015
Version d'Excel : 2007

Message par stepaustras » 13 septembre 2017, 17:21

Bob bah merci ça l'air d'être bon il reste bien dans C:\Users juste un truc en plus si je veux mettre deux fichiers a chercher c'est possible essai.xlsm et essai1.xlsm ?
Avatar du membre
Patty5046
Membre impliqué
Membre impliqué
Messages : 1'088
Appréciations reçues : 108
Inscrit le : 2 février 2016
Version d'Excel : 2016

Message par Patty5046 » 13 septembre 2017, 18:10

Bonsoir, bonsoir à tous
Ce bout de code inspiré de droite et de gauche peut peut-être t'aider:
Option Explicit
Sub SuprFich()
Dim Fso As Object, MonRepertoire As String
Dim f1 As Object, f2 As Object, wb As Workbook
Dim nomfic As String, derslash As Byte

Set Fso = CreateObject("Scripting.FileSystemObject")
MonRepertoire = "C:\Users\"
On Error GoTo suite

For Each f1 In Fso.GetFolder(MonRepertoire).SubFolders
    For Each f2 In f1.Files
    derslash = InStrRev(f2, "\")    'recherche dernier caractère mot à supprimer
    nomfic = Right(f2, Len(f2) - derslash)
        If nomfic = "test.xlsm" Then
            Kill f2
        End If
    Next f2
suite:
Next f1
Set Fso = Nothing
End Sub
Bon courage

Désolée j'arrive après la tempête
s
stepaustras
Membre fidèle
Membre fidèle
Messages : 197
Appréciations reçues : 2
Inscrit le : 12 mai 2015
Version d'Excel : 2007

Message par stepaustras » 13 septembre 2017, 18:18

merci a toi mais il ne fonctionne pas ce code. Il me manque juste pour chercher deux fichiers et voilà ça sera bon. J'aurais pu rajouter deux trois IF mais ça colle pas avec le code de h2so4 c'est pas au même endroit :mrgreen:
If nomfic = "test.xlsm" Then
            Kill f2
        End If
Me faudrait ici avoir deux fichiers, j'ai essayé deux trois truc comme
kfif rep, "essai.xlsm","essai1.xlsm"
mais je suis tellement nul que ça marche pas :lol:
Modifié en dernier par stepaustras le 13 septembre 2017, 18:24, modifié 1 fois.
h
h2so4
Passionné d'Excel
Passionné d'Excel
Messages : 8'617
Appréciations reçues : 297
Inscrit le : 16 juin 2013
Version d'Excel : 2013 UK Windows 10

Message par h2so4 » 13 septembre 2017, 18:24

bonjour,

macro adaptée pour traiter une liste de fichiers
Sub aargh()
    Dim a 'a contiendra un tableau des noms de fichiers à supprimer
    rep = "i:"    ' répertoire à examiner
    liste = "essai.xlsm,essai1.xlsm"
    a = Split(liste, ",") 
    kfif rep, a 'lancer la recherche à partir du répertoire rep
End Sub

Sub kfif(folder, filtre)
' procédure recursive, paramètre folder (nom du répertoire), filtre( tableau contenant les noms des fichiers à supprimer)
    Set fold = CreateObject("Scripting.FileSystemObject").GetFolder(folder)
    On Error GoTo terr
    For Each f In fold.SubFolders ' on parcourt tous les répertoires de ce niveau
        Application.StatusBar = f
        If Right(f, 1) <> "\" Then kfif f & "\", filtre Else kfif f, filtre ' pour chaque répertoire on examine son niveau suivant
    Next
    For Each f In fold.Files 'on parcourt tous les fichiers de ce niveau
        For Each fichier In filtre 'on compare le nom du fichier avec ceux de la liste
            If InStr(f, fichier) <> 0 Then 'si fichier trouvé
                r = MsgBox("supprimer" & f & " OK ?", vbYesNo)
                If r = vbYes Then Kill f ' on le supprime après avoir demandé la confirmation
                Exit For
            End If
        Next
    Next
ici:
    Exit Sub
terr:
    Resume ici
End Sub
Modifié en dernier par h2so4 le 13 septembre 2017, 19:17, modifié 2 fois.
s
stepaustras
Membre fidèle
Membre fidèle
Messages : 197
Appréciations reçues : 2
Inscrit le : 12 mai 2015
Version d'Excel : 2007

Message par stepaustras » 13 septembre 2017, 18:32

Bon c'est OK, ça fonctionne nickel ça scan plus vite qu'un anti virus :lol: Merci a toi h2so4, James007 et aussi a Patty5046 de ta participation, un grand merci ;;)

CHAMPAGNE :-)))) OOOO OOOO
Répondre Sujet précédentSujet suivant
  • Sujets similaires
    Réponses
    Vues
    Dernier message