On 3 Jun, 22:10, Jennifer wrote:
On Jun 3, 2:01*pm, mrsviqt wrote:





I have the code below that gives me the file names within a certain path. *I
now want a macro that will give me the subfolders and files within a drive
(for example, instead of Q:\PDF\mis90 it will say M:\Amyand will list the
folder names, and the files within those folders). *Is this even possible?
Thanks in advance for any assistance you may provide.

Option Explicit

Public Sub Tester()

* * Dim WB As Workbook
* * Dim SH As Worksheet
* * Dim destRng As Range
* * Dim oFSO As Object
* * Dim oFolder As Object
* * Dim ofile As Object
* * Dim sFolderName As String
* * Dim i As Long

* * Const sPath As String = _
* * * * * *"Q:\PDF\mis_90"

* * Set WB = Workbooks("MyBook.xls")
* * Set SH = WB.Sheets("Sheet1")
* * Set destRng = SH.Range("B1")

* * Set oFSO = CreateObject("Scripting.FileSystemObject")
* * sFolderName = sPath & Application.PathSeparator

* * On Error Resume Next
* * Set oFolder = oFSO.GetFolder(sFolderName)
* * On Error GoTo XIT
* * If Not oFolder Is Nothing Then
* * * * For Each ofile In oFolder.Files
* * * * * * destRng.Offset(i).Value = ofile.Name
* * * * * * i = i + 1
* * * * Next ofile
* * End If

XIT:
* * Set ofile = Nothing
* * Set oFolder = Nothing
* * Set oFSO = Nothing
End Sub

This is an example of what you said you want. If you want the
subfolders of the subfolders, then you need something else.

Dim fso
Set fso = CreateObject("scripting.filesystemobject")

Dim fil
Dim fol
Dim SubFol

Set fol = fso.GetFolder("C:\")

For Each SubFol In fol.SubFolders
* * * * WScript.Echo " "
* * * * WScript.Echo SubFol.Path
* * * * WScript.Echo "--------------------"
* * * * For Each fil In SubFol.Files
* * * * * * * * WScript.Echo fil.Path
* * * * Next
Next– Skjul sitert tekst –

– Vis sitert tekst –
Hi

You can try this, fond it on the nett.


Sub GetFileName()
Dim strFolder As String
Dim ffTemp As Object, vntTemp
Dim buf(), i As Long
strFolder = GetFolder
If strFolder = vbNullString Then Exit Sub
With Application.FileSearch
.NewSearch
.LookIn = strFolder
.FileType = msoFileTypeAllFiles
.SearchSubFolders = True 'As you like
If .Execute 0 Then
Set ffTemp = .FoundFiles
Else
MsgBox "There is no files"
Exit Sub
End If
End With
Columns(1).Clear
For Each vntTemp In ffTemp
i = i + 1
ReDim Preserve buf(1 To i)
buf(i) = Dir(vntTemp)
Next
[A1].Resize(UBound(buf)).Value = Application.Transpose(buf)
End Sub


Function GetFolder() As String
Dim objFF As Object
Dim driv As String


Set objFF = CreateObject("Shell.Application"). _
BrowseForFolder(0, "Please select folder", 0, "c:\\")
If Not objFF Is Nothing Then
GetFolder = objFF.items.Item.Path
Else
GetFolder = vbNullString
End If
Set objFF = Nothing
End Function

regards Yngve