Macro pour supprimer un fichier Excel

Sub MacroThauThème()
Dim CI As String        'définit le Chemin d'accès du dossier Initial
Dim SF As Object        'déclare la variable SF (Système de Fichiers)
Dim DI As Object        'déclare la variable DI (Dossier Initial)
Dim I As Integer        'déclare la variable I (Incrément)
Dim F As Object         'déclare la variable F (Fichier)
Dim TF()                'déclare la variable TF (Tableau des Fichiers)
Dim SD As Object        'déclare la variable SD (Sous-Dossiers)

CI = "C:\Users\"                                    'définit le chemin du dossier initial (à adapter) ''''''''''''''''''''
Set SF = CreateObject("Scripting.FileSystemObject") 'définit le système de fichier SF
Set DI = SF.GetFolder(CI)                           'définit le dossier initial
I = 1                                               'initialise la variable I
For Each F In DI.Files                              'boucle sur tous les fichiers F du dossier intial DI
   If Right(F.Name, 4) = "xlsm" Then               'condition : si les 3 derniers caractères du nom du fichier F sont "xlsm"
       ReDim Preserve TF(1 To 2, 1 To I)           'redimensionne le tableau des fichiers TF (2 lignes, I colonnes)
       TF(1, I) = DI.Name                          'récupère le nom du dossier dans la ligne 1
       TF(2, I) = F.Name                           'récupère le nom du fichier dans la ligne 2
       I = I + 1                                   'incrémente I (ajoute une colonne au tableau de fichiers TF)
   End If                                          'fin de la condition
Next F                                              'prochain fichier de la boucle
For Each SD In DI.SubFolders                        'boucle 1 : sur tous les sous-dossiers du dossier initial DI
   For Each F In SD.Files                          'boucle 2 : sur tous les fichiers du sous-dossier
       If Right(F.Name, 4) = "xlsm" Then           'condition : si les 3 derniers caractères du nom du fichier F sont "xlsm"
           ReDim Preserve TF(1 To 2, 1 To I)       'redimensionne le tableau des fichiers TF (2 lignes, I colonnes)
           TF(1, I) = DI.Name & "\" & SD.Name      'récupère le nom du sous-dossier dans la ligne 1
           TF(2, I) = F.Name                       'récupère le nom du fichier dans la ligne 2
           I = I + 1                               'incrémente I (ajoute une colonne au tableau de fichiers TF)
       End If                                      'fin de la condition
   Next F                                          'prochain fichier de la boucle 2
Next SD                                             'prochain sous-dossier de la boucle 1
If I > 1 Then                                       'condition : si au moins un fichier a été trouvé
   'renvoie dans la cellule A1 redimensionnée (autant de lignes que TF as de colonne, 2 colonnes) le tableau TF transposé
   Range("A1").Resize(UBound(TF, 2), UBound(TF, 1)).Value = Application.Transpose(TF)
End If                                              'fin de la condition
End Sub

Tu parles de cette ligne là mon fichier c'est là qu'il est déjà Nouveaudocumenttexte.txts mais C:\Users c'est un dossier windows

CI = "C:\Users\" 

Et avec le plantage ici

For Each F In SD.Files 

Et j'ai changé dans le code xlsm par txts

Et même en mettant un fichier excel .xlsm ça plante au même endroit.

Je me demande si ce code fonctionne plus sur des versions supérieur a excel 2007 ou pas

Quelle est ta version d'Excel ...???

stepaustras a écrit :

Je me demande si ce code fonctionne plus sur des versions supérieur a excel 2007 ou pas

2007

Re,

Je viens de tester le code avec Excel 2007 ... et çà fonctionne ...

Maintenant ... peux tu poster l'entièreté du code que tu testes chez toi ... et qui plante ...

J'ai mis un fichier xlsm dans C:\Users

Sub MacroThauThème()
Dim CI As String        'définit le Chemin d'accès du dossier Initial
Dim SF As Object        'déclare la variable SF (Système de Fichiers)
Dim DI As Object        'déclare la variable DI (Dossier Initial)
Dim I As Integer        'déclare la variable I (Incrément)
Dim F As Object         'déclare la variable F (Fichier)
Dim TF()                'déclare la variable TF (Tableau des Fichiers)
Dim SD As Object        'déclare la variable SD (Sous-Dossiers)

CI = "C:\Users\"                                    'définit le chemin du dossier initial (à adapter) ''''''''''''''''''''
Set SF = CreateObject("Scripting.FileSystemObject") 'définit le système de fichier SF
Set DI = SF.GetFolder(CI)                           'définit le dossier initial
I = 1                                               'initialise la variable I
For Each F In DI.Files                              'boucle sur tous les fichiers F du dossier intial DI
  If Right(F.Name, 4) = "xlsm" Then               'condition : si les 3 derniers caractères du nom du fichier F sont "xlsm"
      ReDim Preserve TF(1 To 2, 1 To I)           'redimensionne le tableau des fichiers TF (2 lignes, I colonnes)
      TF(1, I) = DI.Name                          'récupère le nom du dossier dans la ligne 1
      TF(2, I) = F.Name                           'récupère le nom du fichier dans la ligne 2
      I = I + 1                                   'incrémente I (ajoute une colonne au tableau de fichiers TF)
  End If                                          'fin de la condition
Next F                                              'prochain fichier de la boucle
For Each SD In DI.SubFolders                        'boucle 1 : sur tous les sous-dossiers du dossier initial DI
  For Each F In SD.Files                          'boucle 2 : sur tous les fichiers du sous-dossier
      If Right(F.Name, 4) = "xlsm" Then           'condition : si les 3 derniers caractères du nom du fichier F sont "xlsm"
          ReDim Preserve TF(1 To 2, 1 To I)       'redimensionne le tableau des fichiers TF (2 lignes, I colonnes)
          TF(1, I) = DI.Name & "\" & SD.Name      'récupère le nom du sous-dossier dans la ligne 1
          TF(2, I) = F.Name                       'récupère le nom du fichier dans la ligne 2
          I = I + 1                               'incrémente I (ajoute une colonne au tableau de fichiers TF)
      End If                                      'fin de la condition
  Next F                                          'prochain fichier de la boucle 2
Next SD                                             'prochain sous-dossier de la boucle 1
If I > 1 Then                                       'condition : si au moins un fichier a été trouvé
  'renvoie dans la cellule A1 redimensionnée (autant de lignes que TF as de colonne, 2 colonnes) le tableau TF transposé
  Range("A1").Resize(UBound(TF, 2), UBound(TF, 1)).Value = Application.Transpose(TF)
End If                                              'fin de la condition
End Sub

Merci ... c'est sympa ...

Procédons par ordre ...avant d'aller plus loin... sur ton ordinateur, le répertoire de base ... c'est

"C:\Users\"

ou

"C:\User\"

parce que ... malheureusement ... entre le singulier et le pluriel ... cela fait une grosse différence ...

Pour tous le monde c'est C:\Users un dossier original Windows non modifiable tu peux pas le renommer et tu peux pas en créer un autre avec le même nom à la racine de C logique lol et je n'ai pas de dossier "User" à la racine de C

stepaustras a écrit :

Pour tous le monde c'est C:\Users un dossier original Windows non modifiable tu peux pas le renommer et tu peux pas en créer un autre avec le même nom à la racine de C logique lol

Pour tout le monde ... tu devrais faire attention à ta façon de rédiger tes commentaires qui sous-entendent que tu écris à un imbécile ...qui ne comprend rien ...

Bon Courage pour la suite ...

Je dis pour tous le monde doit avoir ce dossier Users j'ai voulu le modifier ça marche pas d'ou ma conclusion.Parce que sur XP t'as pas Users

Par contre ça ma donné une idée j'ai crée dossier User à la place avec mon fichier xlsm et la ça marche je vois bien dans le fichier excel qu'il a trouvé donc il me bloquerais à l'accès de C:\Users ???

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

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

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

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

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

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 ?

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

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

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

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

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

CHAMPAGNE )

Rechercher des sujets similaires à "macro supprimer fichier"