Aide VBA
ngus
-
Polux31 Messages postés 7219 Statut Membre -
Polux31 Messages postés 7219 Statut Membre -
Bonjour à ttes et à ts,
Voila j'ai une macro qui me permet de lister tous les fichiers d'un dossier, et de me les répertoriers dans un classeur excel.*
Voila, j'aimerais l'améliorer, afin de pour pouvoir l'actualiser avec une macro (VBA) mais sans écraser les fichiers déja lister, ma macro d'actualisation fonctionne bien mais, elle ecrase tout ttes les lignes, et j'aimerais quelles rajoutes silmplement les lignes avec les nouveau fichiers.
Merci de vos réponses
Clément.
ps: voici la macro:
Dim Chemin As String
Sub liste_fichiersRegle()
Dim ScanFic As Office.FileSearch
Dim NomFic As Variant
Dim exten As String
Dim Nbr, i As Long
Call parcourir
exten = InputBox("Saisissez ici l'extension souhaitée pour la recherche. Par ex : xls pour excel, doc pour word, ppt pour powerpoint, pour tous fichiers tapez *.*", "Extension de fichier")
If exten = "" Then
MsgBox "Saisie obligatoire"
Exit Sub
End If
Set ScanFic = Application.FileSearch
With ScanFic
.NewSearch
.LookIn = Chemin
.SearchSubFolders = True
.Filename = exten
.MatchTextExactly = True
.FileType = msoFileTypeAllFiles
Nbr = .Execute
i = 1
For Each NomFic In .FoundFiles
i = i + 1
Sheets("Réglementation").Cells(i + 6, 1).Value = i - 1
Sheets("Réglementation").Cells(i + 6, 2).Value = NomFic
Sheets("Réglementation").Cells(i + 6, 3).Hyperlinks.Add Anchor:=Sheets("Réglementation").Cells(i + 6, 3), Address:=NomFic
Sheets("Réglementation").Cells(i + 6, 4).Value = FileDateTime(NomFic)
Sheets("Réglementation").Cells(i + 6, 5).Value = Right(NomFic, Len(NomFic) - InStr(NomFic, "."))
Next
End With
End Sub
Sub parcourir()
Dim objShell As Object, objFolder As Object, oFolderItem As Object
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.BrowseForFolder(&H0&, "Choisir un répertoire", &H1&)
On Error Resume Next
Set oFolderItem = objFolder.Items.Item
Chemin = oFolderItem.Path
End Sub
Voila j'ai une macro qui me permet de lister tous les fichiers d'un dossier, et de me les répertoriers dans un classeur excel.*
Voila, j'aimerais l'améliorer, afin de pour pouvoir l'actualiser avec une macro (VBA) mais sans écraser les fichiers déja lister, ma macro d'actualisation fonctionne bien mais, elle ecrase tout ttes les lignes, et j'aimerais quelles rajoutes silmplement les lignes avec les nouveau fichiers.
Merci de vos réponses
Clément.
ps: voici la macro:
Dim Chemin As String
Sub liste_fichiersRegle()
Dim ScanFic As Office.FileSearch
Dim NomFic As Variant
Dim exten As String
Dim Nbr, i As Long
Call parcourir
exten = InputBox("Saisissez ici l'extension souhaitée pour la recherche. Par ex : xls pour excel, doc pour word, ppt pour powerpoint, pour tous fichiers tapez *.*", "Extension de fichier")
If exten = "" Then
MsgBox "Saisie obligatoire"
Exit Sub
End If
Set ScanFic = Application.FileSearch
With ScanFic
.NewSearch
.LookIn = Chemin
.SearchSubFolders = True
.Filename = exten
.MatchTextExactly = True
.FileType = msoFileTypeAllFiles
Nbr = .Execute
i = 1
For Each NomFic In .FoundFiles
i = i + 1
Sheets("Réglementation").Cells(i + 6, 1).Value = i - 1
Sheets("Réglementation").Cells(i + 6, 2).Value = NomFic
Sheets("Réglementation").Cells(i + 6, 3).Hyperlinks.Add Anchor:=Sheets("Réglementation").Cells(i + 6, 3), Address:=NomFic
Sheets("Réglementation").Cells(i + 6, 4).Value = FileDateTime(NomFic)
Sheets("Réglementation").Cells(i + 6, 5).Value = Right(NomFic, Len(NomFic) - InStr(NomFic, "."))
Next
End With
End Sub
Sub parcourir()
Dim objShell As Object, objFolder As Object, oFolderItem As Object
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.BrowseForFolder(&H0&, "Choisir un répertoire", &H1&)
On Error Resume Next
Set oFolderItem = objFolder.Items.Item
Chemin = oFolderItem.Path
End Sub
2 réponses
-
Bonjour,
Dim Chemin As String Sub liste_fichiersRegle() Dim ScanFic As Office.FileSearch Dim NomFic As Variant Dim exten As String Dim Nbr, i As Long Call parcourir exten = InputBox("Saisissez ici l'extension souhaitée pour la recherche. Par ex : xls pour excel, doc pour word, ppt pour powerpoint, pour tous fichiers tapez *.*", "Extension de fichier") If exten = "" Then MsgBox "Saisie obligatoire" Exit Sub End If Set ScanFic = Application.FileSearch With ScanFic .NewSearch .LookIn = Chemin .SearchSubFolders = True .Filename = exten .MatchTextExactly = True .FileType = msoFileTypeAllFiles Nbr = .Execute i = Cells(1,1).End(xlDown).Row '<<<< Modification For Each NomFic In .FoundFiles i = i + 1 Sheets("Réglementation").Cells(i + 6, 1).Value = i - 1 Sheets("Réglementation").Cells(i + 6, 2).Value = NomFic Sheets("Réglementation").Cells(i + 6, 3).Hyperlinks.Add Anchor:=Sheets("Réglementation").Cells(i + 6, 3), Address:=NomFic Sheets("Réglementation").Cells(i + 6, 4).Value = FileDateTime(NomFic) Sheets("Réglementation").Cells(i + 6, 5).Value = Right(NomFic, Len(NomFic) - InStr(NomFic, ".")) Next End With End Sub Sub parcourir() Dim objShell As Object, objFolder As Object, oFolderItem As Object Set objShell = CreateObject("Shell.Application") Set objFolder = objShell.BrowseForFolder(&H0&, "Choisir un répertoire", &H1&) On Error Resume Next Set oFolderItem = objFolder.Items.Item Chemin = oFolderItem.Path End Sub
;o) -
je te remercie, peux tu me dire comment lui dire pour qu'a la place du chemin, il m'affiche le nm du fichier?
A cet endroit:
Sheets("Réglementation").Cells(i + 6, 3).Hyperlinks.Add Anchor:=Sheets("Réglementation").Cells(i + 6, 3), Address:=NomFic
Merci
Clem-
Bonjour,
Il me semble que c'est un lien hypertexte . Si tu veux que le lien fonctionne, il faut le chemin complet.
Il serait préférable de mettre le nom du fichier ici : Sheets("Réglementation").Cells(i + 6, 2).Value = NomFic
Il faut utiliser une petite fonction :Public Function RetourneNomFichier(ByVal sChemin As String) As String If InStr(sChemin, "\") = 0 Or Right(sChemin, 1) = "\" Then RetourneNomFichier = "" Exit Function End If RetourneNomFichier = Mid(sChemin, InStrRev(sChemin, "\") + 1) End Function
Et modifier la ligne :
Sheets("Réglementation").Cells(i + 6, 2).Value =RetourneNomFichier(NomFic)
;o) -
-
-
Ce code fonctionne chez moi:
Option Explicit Dim Chemin As String Sub liste_fichiersRegle() Dim ScanFic As Office.FileSearch Dim NomFic As Variant Dim exten As String Dim Nbr, i As Long Call parcourir exten = InputBox("Saisissez ici l'extension souhaitée pour la recherche. Par ex : xls pour excel, doc pour word, ppt pour powerpoint, pour tous fichiers tapez *.*", "Extension de fichier") If exten = "" Then MsgBox "Saisie obligatoire" Exit Sub End If Set ScanFic = Application.FileSearch With ScanFic .NewSearch .LookIn = Chemin .SearchSubFolders = True .Filename = exten .MatchTextExactly = True .FileType = msoFileTypeAllFiles Nbr = .Execute i = Cells(1, 1).End(xlDown).Row '<<<< Modification For Each NomFic In .FoundFiles i = i + 1 Sheets("Réglementation").Cells(i + 6, 1).Value = i - 1 Sheets("Réglementation").Cells(i + 6, 2).Value = RetourneNomFichier(NomFic) Sheets("Réglementation").Cells(i + 6, 3).Hyperlinks.Add Anchor:=Sheets("Réglementation").Cells(i + 6, 3), Address:=NomFic Sheets("Réglementation").Cells(i + 6, 4).Value = FileDateTime(NomFic) Sheets("Réglementation").Cells(i + 6, 5).Value = Right(NomFic, Len(NomFic) - InStr(NomFic, ".")) Next End With End Sub Sub parcourir() Dim objShell As Object, objFolder As Object, oFolderItem As Object Set objShell = CreateObject("Shell.Application") Set objFolder = objShell.BrowseForFolder(&H0&, "Choisir un répertoire", &H1&) On Error Resume Next Set oFolderItem = objFolder.Items.Item Chemin = oFolderItem.Path End Sub Function RetourneNomFichier(ByVal sChemin As String) As String If InStr(sChemin, "\") = 0 Or Right(sChemin, 1) = "\" Then RetourneNomFichier = "" Exit Function End If RetourneNomFichier = Mid(sChemin, InStrRev(sChemin, "\") + 1) End Function
;o)
-
