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
CHAMPAGNE