Bonjour
j'ai récupéré sur internet une macro qui permet d'afficher dans un classeur
le nom des fichiers d'un répertoire
que l'on choisit dans une boite de dialogue
je ne suis très fort en VB et je souhaiterai trouver une macro qui m'
afficherait le nom des fichiers du répertoire ou se trouve mon fichier excel
le répertoire n 'étant pas forcement le même à chaque fois
ceci pour des besoins professionnels
mon fichier excel étant dans le répertoire toto je souhaiterai en activant
la macro qu 'il m'affiche automatiquement dans une colonne les noms de tous
es fichiers contenus dans ce répertoire
le même fichier étant dans le répertoire tata j 'aimerai qu'il m'affiche les
noms du répertoire tata
Vous trouverez ci-joint la macro que j'ai récupérée et que j 'aimerai
pouvoir modifier
merci de votre aide
ceci étant pour le boulot voici mon adresse ou vous pouvez me repondre
Guy.Le-Mouel@renault.com
GUY
Public Type BROWSEINFO
hOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End Type
'32-bit API declarations
Declare Function SHGetPathFromIDList Lib "shell32.dll" _
Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String)
As Long
Declare Function SHBrowseForFolder Lib "shell32.dll" _
Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
Function GetDirectory(Optional Msg) As String
Dim bInfo As BROWSEINFO
Dim path As String
Dim r As Long, x As Long, pos As Integer
bInfo.pidlRoot = 0&
If IsMissing(Msg) Then
bInfo.lpszTitle = "Select a folder."
Else
bInfo.lpszTitle = Msg
End If
bInfo.ulFlags = &h1
x = SHBrowseForFolder(bInfo)
path = Space$(512)
r = SHGetPathFromIDList(ByVal x, ByVal path)
If r Then
pos = InStr(path, Chr$(0))
GetDirectory = Left(path, pos - 1)
Range("a2") = GetDirectory
Else
GetDirectory = ""
End If
End Function
'Appel a la procedure :
Sub appel()
Range("B2:B2000").ClearContents
Msg = "Selection de la directory désirée"
ChDir GetDirectory(Msg)
End Sub
'Recupere les noms de fichiers d'un répertoire dans un tableau
Sub RecupNomFichier(ByVal Chemin As String, ByRef Tableau As Variant)
Dim Fichier As String
Dim Compteur As Integer
Dim LigneCompteur As Integer
'Chemin = Application.InputBox(Prompt:="Quel répertoire voulez-vous
imprimer?")
Chemin = Range("A2")
Chemin = Chemin + "\*.*"
'Range("B1") = Chemin
Compteur = 1
Fichier = Dir(Chemin)
Do While (Len(Fichier) > 0)
ReDim Preserve Tableau(Compteur)
Tableau(Compteur - 1) = Fichier
LigneCompteur = Compteur + 1
ActiveSheet.Range("B" & LigneCompteur).Value = Tableau(Compteur - 1)
Compteur = Compteur + 1
Fichier = Dir()
Loop
End Sub
Sub RecupFichierTableau()
On Error Resume Next
Application.ScreenUpdating = False
Dim Tableau() As String
Call RecupNomFichier(Chemin, Tableau)
FiltreAlpha
End Sub
Sub Imprim()
ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True
End Sub
'Range("Données").PrintOut ActivePrinter:="Brother HL-730 sur LPT1:"
Sub FiltreAlpha()
Columns("B:B").Select
Selection.Sort Key1:=Range("B2"), Order1:=xlAscending, Header:=xlGuess,
_
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
With Selection
.HorizontalAlignment = xlGeneral
.Orientation = 0
End With
With Selection
.HorizontalAlignment = xlRight
.Orientation = 0
End With
Range("B1").Select
End Sub
Cette action est irreversible, confirmez la suppression du commentaire ?
Signaler le commentaire
Veuillez sélectionner un problème
Nudité
Violence
Harcèlement
Fraude
Vente illégale
Discours haineux
Terrorisme
Autre
Michel Pierron
Salut Moi; Essaie ceci:
Sub DirList() Dim iCount As Integer, ePath As String, sPath As String sPath = ThisWorkbook.Path Application.DisplayStatusBar = True Application.ScreenUpdating = False Workbooks.Add Application.StatusBar = "Traitement répertoire " & sPath & "..." ePath = Dir(sPath & "*.*", vbNormal + vbHidden) While ePath <> "" If ePath <> "." And ePath <> ".." Then iCount = iCount + 1 ActiveSheet.Cells(iCount, 1) = ePath ePath = Dir() End If Wend Application.StatusBar = False ActiveSheet.Columns(1).Columns.AutoFit End Sub
MP
"GUY" a écrit dans le message de news:3f749ce2$0$27025$
Bonjour j'ai récupéré sur internet une macro qui permet d'afficher dans un classeur
le nom des fichiers d'un répertoire que l'on choisit dans une boite de dialogue je ne suis très fort en VB et je souhaiterai trouver une macro qui m' afficherait le nom des fichiers du répertoire ou se trouve mon fichier excel
le répertoire n 'étant pas forcement le même à chaque fois ceci pour des besoins professionnels mon fichier excel étant dans le répertoire toto je souhaiterai en activant la macro qu 'il m'affiche automatiquement dans une colonne les noms de tous
es fichiers contenus dans ce répertoire le même fichier étant dans le répertoire tata j 'aimerai qu'il m'affiche les
noms du répertoire tata Vous trouverez ci-joint la macro que j'ai récupérée et que j 'aimerai pouvoir modifier merci de votre aide
ceci étant pour le boulot voici mon adresse ou vous pouvez me repondre
GUY
Public Type BROWSEINFO hOwner As Long pidlRoot As Long pszDisplayName As String lpszTitle As String ulFlags As Long lpfn As Long lParam As Long iImage As Long End Type '32-bit API declarations Declare Function SHGetPathFromIDList Lib "shell32.dll" _ Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long Declare Function SHBrowseForFolder Lib "shell32.dll" _ Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
Function GetDirectory(Optional Msg) As String Dim bInfo As BROWSEINFO Dim path As String Dim r As Long, x As Long, pos As Integer bInfo.pidlRoot = 0& If IsMissing(Msg) Then bInfo.lpszTitle = "Select a folder." Else bInfo.lpszTitle = Msg End If bInfo.ulFlags = &h1 x = SHBrowseForFolder(bInfo) path = Space$(512) r = SHGetPathFromIDList(ByVal x, ByVal path) If r Then pos = InStr(path, Chr$(0)) GetDirectory = Left(path, pos - 1) Range("a2") = GetDirectory Else GetDirectory = "" End If End Function 'Appel a la procedure : Sub appel() Range("B2:B2000").ClearContents Msg = "Selection de la directory désirée" ChDir GetDirectory(Msg) End Sub 'Recupere les noms de fichiers d'un répertoire dans un tableau
Sub RecupNomFichier(ByVal Chemin As String, ByRef Tableau As Variant) Dim Fichier As String Dim Compteur As Integer Dim LigneCompteur As Integer 'Chemin = Application.InputBox(Prompt:="Quel répertoire voulez-vous imprimer?") Chemin = Range("A2") Chemin = Chemin + "*.*" 'Range("B1") = Chemin Compteur = 1 Fichier = Dir(Chemin) Do While (Len(Fichier) > 0) ReDim Preserve Tableau(Compteur) Tableau(Compteur - 1) = Fichier LigneCompteur = Compteur + 1 ActiveSheet.Range("B" & LigneCompteur).Value = Tableau(Compteur - 1) Compteur = Compteur + 1 Fichier = Dir()
Loop End Sub Sub RecupFichierTableau() On Error Resume Next Application.ScreenUpdating = False Dim Tableau() As String Call RecupNomFichier(Chemin, Tableau) FiltreAlpha End Sub Sub Imprim() ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True End Sub 'Range("Données").PrintOut ActivePrinter:="Brother HL-730 sur LPT1:"
_ OrderCustom:=1, MatchCase:úlse, Orientation:=xlTopToBottom With Selection .HorizontalAlignment = xlGeneral .Orientation = 0 End With With Selection .HorizontalAlignment = xlRight .Orientation = 0 End With Range("B1").Select End Sub
GUY
Salut Moi;
Essaie ceci:
Sub DirList()
Dim iCount As Integer, ePath As String, sPath As String
sPath = ThisWorkbook.Path
Application.DisplayStatusBar = True
Application.ScreenUpdating = False
Workbooks.Add
Application.StatusBar = "Traitement répertoire " & sPath & "..."
ePath = Dir(sPath & "*.*", vbNormal + vbHidden)
While ePath <> ""
If ePath <> "." And ePath <> ".." Then
iCount = iCount + 1
ActiveSheet.Cells(iCount, 1) = ePath
ePath = Dir()
End If
Wend
Application.StatusBar = False
ActiveSheet.Columns(1).Columns.AutoFit
End Sub
MP
"GUY" <moi@free.com> a écrit dans le message de
news:3f749ce2$0$27025$626a54ce@news.free.fr...
Bonjour
j'ai récupéré sur internet une macro qui permet d'afficher dans un
classeur
le nom des fichiers d'un répertoire
que l'on choisit dans une boite de dialogue
je ne suis très fort en VB et je souhaiterai trouver une macro qui m'
afficherait le nom des fichiers du répertoire ou se trouve mon fichier
excel
le répertoire n 'étant pas forcement le même à chaque fois
ceci pour des besoins professionnels
mon fichier excel étant dans le répertoire toto je souhaiterai en activant
la macro qu 'il m'affiche automatiquement dans une colonne les noms de
tous
es fichiers contenus dans ce répertoire
le même fichier étant dans le répertoire tata j 'aimerai qu'il m'affiche
les
noms du répertoire tata
Vous trouverez ci-joint la macro que j'ai récupérée et que j 'aimerai
pouvoir modifier
merci de votre aide
ceci étant pour le boulot voici mon adresse ou vous pouvez me repondre
Guy.Le-Mouel@renault.com
GUY
Public Type BROWSEINFO
hOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End Type
'32-bit API declarations
Declare Function SHGetPathFromIDList Lib "shell32.dll" _
Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String)
As Long
Declare Function SHBrowseForFolder Lib "shell32.dll" _
Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
Function GetDirectory(Optional Msg) As String
Dim bInfo As BROWSEINFO
Dim path As String
Dim r As Long, x As Long, pos As Integer
bInfo.pidlRoot = 0&
If IsMissing(Msg) Then
bInfo.lpszTitle = "Select a folder."
Else
bInfo.lpszTitle = Msg
End If
bInfo.ulFlags = &h1
x = SHBrowseForFolder(bInfo)
path = Space$(512)
r = SHGetPathFromIDList(ByVal x, ByVal path)
If r Then
pos = InStr(path, Chr$(0))
GetDirectory = Left(path, pos - 1)
Range("a2") = GetDirectory
Else
GetDirectory = ""
End If
End Function
'Appel a la procedure :
Sub appel()
Range("B2:B2000").ClearContents
Msg = "Selection de la directory désirée"
ChDir GetDirectory(Msg)
End Sub
'Recupere les noms de fichiers d'un répertoire dans un tableau
Sub RecupNomFichier(ByVal Chemin As String, ByRef Tableau As Variant)
Dim Fichier As String
Dim Compteur As Integer
Dim LigneCompteur As Integer
'Chemin = Application.InputBox(Prompt:="Quel répertoire voulez-vous
imprimer?")
Chemin = Range("A2")
Chemin = Chemin + "*.*"
'Range("B1") = Chemin
Compteur = 1
Fichier = Dir(Chemin)
Do While (Len(Fichier) > 0)
ReDim Preserve Tableau(Compteur)
Tableau(Compteur - 1) = Fichier
LigneCompteur = Compteur + 1
ActiveSheet.Range("B" & LigneCompteur).Value = Tableau(Compteur - 1)
Compteur = Compteur + 1
Fichier = Dir()
Loop
End Sub
Sub RecupFichierTableau()
On Error Resume Next
Application.ScreenUpdating = False
Dim Tableau() As String
Call RecupNomFichier(Chemin, Tableau)
FiltreAlpha
End Sub
Sub Imprim()
ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True
End Sub
'Range("Données").PrintOut ActivePrinter:="Brother HL-730 sur LPT1:"
_
OrderCustom:=1, MatchCase:úlse, Orientation:=xlTopToBottom
With Selection
.HorizontalAlignment = xlGeneral
.Orientation = 0
End With
With Selection
.HorizontalAlignment = xlRight
.Orientation = 0
End With
Range("B1").Select
End Sub
Sub DirList() Dim iCount As Integer, ePath As String, sPath As String sPath = ThisWorkbook.Path Application.DisplayStatusBar = True Application.ScreenUpdating = False Workbooks.Add Application.StatusBar = "Traitement répertoire " & sPath & "..." ePath = Dir(sPath & "*.*", vbNormal + vbHidden) While ePath <> "" If ePath <> "." And ePath <> ".." Then iCount = iCount + 1 ActiveSheet.Cells(iCount, 1) = ePath ePath = Dir() End If Wend Application.StatusBar = False ActiveSheet.Columns(1).Columns.AutoFit End Sub
MP
"GUY" a écrit dans le message de news:3f749ce2$0$27025$
Bonjour j'ai récupéré sur internet une macro qui permet d'afficher dans un classeur
le nom des fichiers d'un répertoire que l'on choisit dans une boite de dialogue je ne suis très fort en VB et je souhaiterai trouver une macro qui m' afficherait le nom des fichiers du répertoire ou se trouve mon fichier excel
le répertoire n 'étant pas forcement le même à chaque fois ceci pour des besoins professionnels mon fichier excel étant dans le répertoire toto je souhaiterai en activant la macro qu 'il m'affiche automatiquement dans une colonne les noms de tous
es fichiers contenus dans ce répertoire le même fichier étant dans le répertoire tata j 'aimerai qu'il m'affiche les
noms du répertoire tata Vous trouverez ci-joint la macro que j'ai récupérée et que j 'aimerai pouvoir modifier merci de votre aide
ceci étant pour le boulot voici mon adresse ou vous pouvez me repondre
GUY
Public Type BROWSEINFO hOwner As Long pidlRoot As Long pszDisplayName As String lpszTitle As String ulFlags As Long lpfn As Long lParam As Long iImage As Long End Type '32-bit API declarations Declare Function SHGetPathFromIDList Lib "shell32.dll" _ Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long Declare Function SHBrowseForFolder Lib "shell32.dll" _ Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
Function GetDirectory(Optional Msg) As String Dim bInfo As BROWSEINFO Dim path As String Dim r As Long, x As Long, pos As Integer bInfo.pidlRoot = 0& If IsMissing(Msg) Then bInfo.lpszTitle = "Select a folder." Else bInfo.lpszTitle = Msg End If bInfo.ulFlags = &h1 x = SHBrowseForFolder(bInfo) path = Space$(512) r = SHGetPathFromIDList(ByVal x, ByVal path) If r Then pos = InStr(path, Chr$(0)) GetDirectory = Left(path, pos - 1) Range("a2") = GetDirectory Else GetDirectory = "" End If End Function 'Appel a la procedure : Sub appel() Range("B2:B2000").ClearContents Msg = "Selection de la directory désirée" ChDir GetDirectory(Msg) End Sub 'Recupere les noms de fichiers d'un répertoire dans un tableau
Sub RecupNomFichier(ByVal Chemin As String, ByRef Tableau As Variant) Dim Fichier As String Dim Compteur As Integer Dim LigneCompteur As Integer 'Chemin = Application.InputBox(Prompt:="Quel répertoire voulez-vous imprimer?") Chemin = Range("A2") Chemin = Chemin + "*.*" 'Range("B1") = Chemin Compteur = 1 Fichier = Dir(Chemin) Do While (Len(Fichier) > 0) ReDim Preserve Tableau(Compteur) Tableau(Compteur - 1) = Fichier LigneCompteur = Compteur + 1 ActiveSheet.Range("B" & LigneCompteur).Value = Tableau(Compteur - 1) Compteur = Compteur + 1 Fichier = Dir()
Loop End Sub Sub RecupFichierTableau() On Error Resume Next Application.ScreenUpdating = False Dim Tableau() As String Call RecupNomFichier(Chemin, Tableau) FiltreAlpha End Sub Sub Imprim() ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True End Sub 'Range("Données").PrintOut ActivePrinter:="Brother HL-730 sur LPT1:"
_ OrderCustom:=1, MatchCase:úlse, Orientation:=xlTopToBottom With Selection .HorizontalAlignment = xlGeneral .Orientation = 0 End With With Selection .HorizontalAlignment = xlRight .Orientation = 0 End With Range("B1").Select End Sub
GUY
GUY
C'est exactement ce que je voulais merci infiniment GUY Michel Pierron a écrit dans le message : #y#
Salut Moi; Essaie ceci:
Sub DirList() Dim iCount As Integer, ePath As String, sPath As String sPath = ThisWorkbook.Path Application.DisplayStatusBar = True Application.ScreenUpdating = False Workbooks.Add Application.StatusBar = "Traitement répertoire " & sPath & "..." ePath = Dir(sPath & "*.*", vbNormal + vbHidden) While ePath <> "" If ePath <> "." And ePath <> ".." Then iCount = iCount + 1 ActiveSheet.Cells(iCount, 1) = ePath ePath = Dir() End If Wend Application.StatusBar = False ActiveSheet.Columns(1).Columns.AutoFit End Sub
MP
"GUY" a écrit dans le message de news:3f749ce2$0$27025$
Bonjour j'ai récupéré sur internet une macro qui permet d'afficher dans un classeur
le nom des fichiers d'un répertoire que l'on choisit dans une boite de dialogue je ne suis très fort en VB et je souhaiterai trouver une macro qui m' afficherait le nom des fichiers du répertoire ou se trouve mon fichier excel
le répertoire n 'étant pas forcement le même à chaque fois ceci pour des besoins professionnels mon fichier excel étant dans le répertoire toto je souhaiterai en activant
la macro qu 'il m'affiche automatiquement dans une colonne les noms de tous
es fichiers contenus dans ce répertoire le même fichier étant dans le répertoire tata j 'aimerai qu'il m'affiche les
noms du répertoire tata Vous trouverez ci-joint la macro que j'ai récupérée et que j 'aimerai pouvoir modifier merci de votre aide
ceci étant pour le boulot voici mon adresse ou vous pouvez me repondre
GUY
Public Type BROWSEINFO hOwner As Long pidlRoot As Long pszDisplayName As String lpszTitle As String ulFlags As Long lpfn As Long lParam As Long iImage As Long End Type '32-bit API declarations Declare Function SHGetPathFromIDList Lib "shell32.dll" _ Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String)
As Long Declare Function SHBrowseForFolder Lib "shell32.dll" _ Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
Function GetDirectory(Optional Msg) As String Dim bInfo As BROWSEINFO Dim path As String Dim r As Long, x As Long, pos As Integer bInfo.pidlRoot = 0& If IsMissing(Msg) Then bInfo.lpszTitle = "Select a folder." Else bInfo.lpszTitle = Msg End If bInfo.ulFlags = &h1 x = SHBrowseForFolder(bInfo) path = Space$(512) r = SHGetPathFromIDList(ByVal x, ByVal path) If r Then pos = InStr(path, Chr$(0)) GetDirectory = Left(path, pos - 1) Range("a2") = GetDirectory Else GetDirectory = "" End If End Function 'Appel a la procedure : Sub appel() Range("B2:B2000").ClearContents Msg = "Selection de la directory désirée" ChDir GetDirectory(Msg) End Sub 'Recupere les noms de fichiers d'un répertoire dans un tableau
Sub RecupNomFichier(ByVal Chemin As String, ByRef Tableau As Variant) Dim Fichier As String Dim Compteur As Integer Dim LigneCompteur As Integer 'Chemin = Application.InputBox(Prompt:="Quel répertoire voulez-vous imprimer?") Chemin = Range("A2") Chemin = Chemin + "*.*" 'Range("B1") = Chemin Compteur = 1 Fichier = Dir(Chemin) Do While (Len(Fichier) > 0) ReDim Preserve Tableau(Compteur) Tableau(Compteur - 1) = Fichier LigneCompteur = Compteur + 1 ActiveSheet.Range("B" & LigneCompteur).Value = Tableau(Compteur - 1) Compteur = Compteur + 1 Fichier = Dir()
Loop End Sub Sub RecupFichierTableau() On Error Resume Next Application.ScreenUpdating = False Dim Tableau() As String Call RecupNomFichier(Chemin, Tableau) FiltreAlpha End Sub Sub Imprim() ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True End Sub 'Range("Données").PrintOut ActivePrinter:="Brother HL-730 sur LPT1:"
_ OrderCustom:=1, MatchCase:úlse, Orientation:=xlTopToBottom With Selection .HorizontalAlignment = xlGeneral .Orientation = 0 End With With Selection .HorizontalAlignment = xlRight .Orientation = 0 End With Range("B1").Select End Sub
GUY
C'est exactement ce que je voulais merci infiniment
GUY
Michel Pierron <michel.pierron@free.fr> a écrit dans le message :
#y#MpBOhDHA.1200@TK2MSFTNGP12.phx.gbl...
Salut Moi;
Essaie ceci:
Sub DirList()
Dim iCount As Integer, ePath As String, sPath As String
sPath = ThisWorkbook.Path
Application.DisplayStatusBar = True
Application.ScreenUpdating = False
Workbooks.Add
Application.StatusBar = "Traitement répertoire " & sPath & "..."
ePath = Dir(sPath & "*.*", vbNormal + vbHidden)
While ePath <> ""
If ePath <> "." And ePath <> ".." Then
iCount = iCount + 1
ActiveSheet.Cells(iCount, 1) = ePath
ePath = Dir()
End If
Wend
Application.StatusBar = False
ActiveSheet.Columns(1).Columns.AutoFit
End Sub
MP
"GUY" <moi@free.com> a écrit dans le message de
news:3f749ce2$0$27025$626a54ce@news.free.fr...
Bonjour
j'ai récupéré sur internet une macro qui permet d'afficher dans un
classeur
le nom des fichiers d'un répertoire
que l'on choisit dans une boite de dialogue
je ne suis très fort en VB et je souhaiterai trouver une macro qui m'
afficherait le nom des fichiers du répertoire ou se trouve mon fichier
excel
le répertoire n 'étant pas forcement le même à chaque fois
ceci pour des besoins professionnels
mon fichier excel étant dans le répertoire toto je souhaiterai en
activant
la macro qu 'il m'affiche automatiquement dans une colonne les noms de
tous
es fichiers contenus dans ce répertoire
le même fichier étant dans le répertoire tata j 'aimerai qu'il m'affiche
les
noms du répertoire tata
Vous trouverez ci-joint la macro que j'ai récupérée et que j 'aimerai
pouvoir modifier
merci de votre aide
ceci étant pour le boulot voici mon adresse ou vous pouvez me repondre
Guy.Le-Mouel@renault.com
GUY
Public Type BROWSEINFO
hOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End Type
'32-bit API declarations
Declare Function SHGetPathFromIDList Lib "shell32.dll" _
Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As
String)
As Long
Declare Function SHBrowseForFolder Lib "shell32.dll" _
Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
Function GetDirectory(Optional Msg) As String
Dim bInfo As BROWSEINFO
Dim path As String
Dim r As Long, x As Long, pos As Integer
bInfo.pidlRoot = 0&
If IsMissing(Msg) Then
bInfo.lpszTitle = "Select a folder."
Else
bInfo.lpszTitle = Msg
End If
bInfo.ulFlags = &h1
x = SHBrowseForFolder(bInfo)
path = Space$(512)
r = SHGetPathFromIDList(ByVal x, ByVal path)
If r Then
pos = InStr(path, Chr$(0))
GetDirectory = Left(path, pos - 1)
Range("a2") = GetDirectory
Else
GetDirectory = ""
End If
End Function
'Appel a la procedure :
Sub appel()
Range("B2:B2000").ClearContents
Msg = "Selection de la directory désirée"
ChDir GetDirectory(Msg)
End Sub
'Recupere les noms de fichiers d'un répertoire dans un tableau
Sub RecupNomFichier(ByVal Chemin As String, ByRef Tableau As Variant)
Dim Fichier As String
Dim Compteur As Integer
Dim LigneCompteur As Integer
'Chemin = Application.InputBox(Prompt:="Quel répertoire voulez-vous
imprimer?")
Chemin = Range("A2")
Chemin = Chemin + "*.*"
'Range("B1") = Chemin
Compteur = 1
Fichier = Dir(Chemin)
Do While (Len(Fichier) > 0)
ReDim Preserve Tableau(Compteur)
Tableau(Compteur - 1) = Fichier
LigneCompteur = Compteur + 1
ActiveSheet.Range("B" & LigneCompteur).Value = Tableau(Compteur - 1)
Compteur = Compteur + 1
Fichier = Dir()
Loop
End Sub
Sub RecupFichierTableau()
On Error Resume Next
Application.ScreenUpdating = False
Dim Tableau() As String
Call RecupNomFichier(Chemin, Tableau)
FiltreAlpha
End Sub
Sub Imprim()
ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True
End Sub
'Range("Données").PrintOut ActivePrinter:="Brother HL-730 sur LPT1:"
_
OrderCustom:=1, MatchCase:úlse, Orientation:=xlTopToBottom
With Selection
.HorizontalAlignment = xlGeneral
.Orientation = 0
End With
With Selection
.HorizontalAlignment = xlRight
.Orientation = 0
End With
Range("B1").Select
End Sub
C'est exactement ce que je voulais merci infiniment GUY Michel Pierron a écrit dans le message : #y#
Salut Moi; Essaie ceci:
Sub DirList() Dim iCount As Integer, ePath As String, sPath As String sPath = ThisWorkbook.Path Application.DisplayStatusBar = True Application.ScreenUpdating = False Workbooks.Add Application.StatusBar = "Traitement répertoire " & sPath & "..." ePath = Dir(sPath & "*.*", vbNormal + vbHidden) While ePath <> "" If ePath <> "." And ePath <> ".." Then iCount = iCount + 1 ActiveSheet.Cells(iCount, 1) = ePath ePath = Dir() End If Wend Application.StatusBar = False ActiveSheet.Columns(1).Columns.AutoFit End Sub
MP
"GUY" a écrit dans le message de news:3f749ce2$0$27025$
Bonjour j'ai récupéré sur internet une macro qui permet d'afficher dans un classeur
le nom des fichiers d'un répertoire que l'on choisit dans une boite de dialogue je ne suis très fort en VB et je souhaiterai trouver une macro qui m' afficherait le nom des fichiers du répertoire ou se trouve mon fichier excel
le répertoire n 'étant pas forcement le même à chaque fois ceci pour des besoins professionnels mon fichier excel étant dans le répertoire toto je souhaiterai en activant
la macro qu 'il m'affiche automatiquement dans une colonne les noms de tous
es fichiers contenus dans ce répertoire le même fichier étant dans le répertoire tata j 'aimerai qu'il m'affiche les
noms du répertoire tata Vous trouverez ci-joint la macro que j'ai récupérée et que j 'aimerai pouvoir modifier merci de votre aide
ceci étant pour le boulot voici mon adresse ou vous pouvez me repondre
GUY
Public Type BROWSEINFO hOwner As Long pidlRoot As Long pszDisplayName As String lpszTitle As String ulFlags As Long lpfn As Long lParam As Long iImage As Long End Type '32-bit API declarations Declare Function SHGetPathFromIDList Lib "shell32.dll" _ Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String)
As Long Declare Function SHBrowseForFolder Lib "shell32.dll" _ Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
Function GetDirectory(Optional Msg) As String Dim bInfo As BROWSEINFO Dim path As String Dim r As Long, x As Long, pos As Integer bInfo.pidlRoot = 0& If IsMissing(Msg) Then bInfo.lpszTitle = "Select a folder." Else bInfo.lpszTitle = Msg End If bInfo.ulFlags = &h1 x = SHBrowseForFolder(bInfo) path = Space$(512) r = SHGetPathFromIDList(ByVal x, ByVal path) If r Then pos = InStr(path, Chr$(0)) GetDirectory = Left(path, pos - 1) Range("a2") = GetDirectory Else GetDirectory = "" End If End Function 'Appel a la procedure : Sub appel() Range("B2:B2000").ClearContents Msg = "Selection de la directory désirée" ChDir GetDirectory(Msg) End Sub 'Recupere les noms de fichiers d'un répertoire dans un tableau
Sub RecupNomFichier(ByVal Chemin As String, ByRef Tableau As Variant) Dim Fichier As String Dim Compteur As Integer Dim LigneCompteur As Integer 'Chemin = Application.InputBox(Prompt:="Quel répertoire voulez-vous imprimer?") Chemin = Range("A2") Chemin = Chemin + "*.*" 'Range("B1") = Chemin Compteur = 1 Fichier = Dir(Chemin) Do While (Len(Fichier) > 0) ReDim Preserve Tableau(Compteur) Tableau(Compteur - 1) = Fichier LigneCompteur = Compteur + 1 ActiveSheet.Range("B" & LigneCompteur).Value = Tableau(Compteur - 1) Compteur = Compteur + 1 Fichier = Dir()
Loop End Sub Sub RecupFichierTableau() On Error Resume Next Application.ScreenUpdating = False Dim Tableau() As String Call RecupNomFichier(Chemin, Tableau) FiltreAlpha End Sub Sub Imprim() ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True End Sub 'Range("Données").PrintOut ActivePrinter:="Brother HL-730 sur LPT1:"
_ OrderCustom:=1, MatchCase:úlse, Orientation:=xlTopToBottom With Selection .HorizontalAlignment = xlGeneral .Orientation = 0 End With With Selection .HorizontalAlignment = xlRight .Orientation = 0 End With Range("B1").Select End Sub
