Sujet Précédent Sujet Suivant

Aide VBA

Fermé
ngus - 28 avril 2010 à 09:57
Polux31 Messages postés 6917 Date d'inscription mardi 25 septembre 2007 Statut Membre Dernière intervention 1 novembre 2016 - 29 avril 2010 à 13:54
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


2 réponses

Réponse 1 / 2
Polux31 Messages postés 6917 Date d'inscription mardi 25 septembre 2007 Statut Membre Dernière intervention 1 novembre 2016 1 204
28 avril 2010 à 11:09
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)
0
Réponse 2 / 2
ngus
29 avril 2010 à 11:04
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
0
Polux31 Messages postés 6917 Date d'inscription mardi 25 septembre 2007 Statut Membre Dernière intervention 1 novembre 2016 1 204
29 avril 2010 à 11:28
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)
0
ngus
29 avril 2010 à 13:11
En testant ce programme il me met erreur : argument ou appel de procedure incorrecte
Que faire?
0
Polux31 Messages postés 6917 Date d'inscription mardi 25 septembre 2007 Statut Membre Dernière intervention 1 novembre 2016 1 204
29 avril 2010 à 13:52
Sur quelle ligne met-il l'erreur ?
0
Polux31 Messages postés 6917 Date d'inscription mardi 25 septembre 2007 Statut Membre Dernière intervention 1 novembre 2016 1 204
29 avril 2010 à 13:54
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)
0

Discussions similaires

"L'indice n'appartient à la sélection" + VBA
fleur.31 -
geosevda -

2 réponses
Erreur d'exécution 13 Incompatibilité de type
grace -
pijaku -

5 réponses
ouverture d'un fichier excel à partir d'un code VBA
TraderAS -
pijaku -

3 réponses
Méthode find dans VBA - Recherche de données sous Excel
baissaoui -
baissaoui -

0 réponse
appliquer une pause dans une macro vba excel
ch'duj -
lerif25 -

10 réponses