ExcelBanter - Display names

ExcelBanter (https://www.excelbanter.com/)

- Excel Discussion (Misc queries) (https://www.excelbanter.com/excel-discussion-misc-queries/)

- - Display names (https://www.excelbanter.com/excel-discussion-misc-queries/83225-display-names.html)

Hi all,

Can anyone tell me a way to display all the names of xls files in a
folder in a separate spreadsheet?

Thanks in advance,

M.Ravindran

--
m_ravindran
------------------------------------------------------------------------
m_ravindran's Profile: http://www.excelforum.com/member.php...o&userid=28668
View this thread: http://www.excelforum.com/showthread...hreadid=532881

You can do this manually by using the inserthyperlink (or Ctrl+K) and
browsing to the files individually.

--
abehart
------------------------------------------------------------------------
abehart's Profile: http://www.excelforum.com/member.php...o&userid=33482
View this thread: http://www.excelforum.com/showthread...hreadid=532881

Hello
Sub ListExcelwbks()
With Application.FileSearch
..NewSearch
..LookIn = "C:\My documents\Excel\samples"
..FileType = msoFileTypeExcelWorkbooks
..SearchSubFolders = False 'or true
If .Execute 0 Then
For i = 1 To .FoundFiles.Count
Cells(i, 1) = .FoundFiles(i)
Next i
Else: MsgBox "No Excel workbooks were found in the specified directory",
vbInformation, "Search result"
End If
End With
End Sub

HTH
Cordially
Pascal

"m_ravindran" a
écrit dans le message de news:
...

Hi all,

Can anyone tell me a way to display all the names of xls files in a
folder in a separate spreadsheet?

Thanks in advance,

M.Ravindran

--
m_ravindran
------------------------------------------------------------------------
m_ravindran's Profile:
http://www.excelforum.com/member.php...o&userid=28668
View this thread: http://www.excelforum.com/showthread...hreadid=532881

This does all subfolders as well, and hyperlinks them

Option Explicit

Private cnt As Long
Private arfiles
Private level As Long

Sub Folders()
Dim i As Long
Dim sFolder As String
Dim iStart As Long
Dim iEnd As Long
Dim fOutline As Boolean

arfiles = Array()
cnt = -1
level = 1

sFolder = "E:\"
ReDim arfiles(2, 0)
If sFolder < "" Then
SelectFiles sFolder
Application.DisplayAlerts = False
On Error Resume Next
Worksheets("Files").Delete
On Error GoTo 0
Application.DisplayAlerts = True
Worksheets.Add.Name = "Files"
With ActiveSheet
For i = LBound(arfiles, 2) To UBound(arfiles, 2)
If arfiles(0, i) = "" Then
If fOutline Then
Rows(iStart + 1 & ":" & iEnd).Rows.Group
End If
With .Cells(i + 1, arfiles(2, i))
.Value = arfiles(1, i)
.Font.Bold = True
End With
iStart = i + 1
iEnd = iStart
fOutline = False
Else
.Hyperlinks.Add Anchor:=.Cells(i + 1, arfiles(2, i)), _
Address:=arfiles(0, i), _
TextToDisplay:=arfiles(1, i)
iEnd = iEnd + 1
fOutline = True
End If
Next
.Columns("A:Z").ColumnWidth = 5
End With
End If
'just in case there is another set to group
If fOutline Then
Rows(iStart + 1 & ":" & iEnd).Rows.Group
End If

Columns("A:Z").ColumnWidth = 5
ActiveSheet.Outline.ShowLevels RowLevels:=1
ActiveWindow.DisplayGridlines = False

End Sub

'-----------------------------------------------------------------------
Sub SelectFiles(Optional sPath As String)
'-----------------------------------------------------------------------
Static FSO As Object
Dim oSubFolder As Object
Dim oFolder As Object
Dim oFile As Object
Dim oFiles As Object
Dim arPath

If FSO Is Nothing Then
Set FSO = CreateObject("Scripting.FileSystemObject")
End If

If sPath = "" Then
sPath = CurDir
End If

arPath = Split(sPath, "\")
cnt = cnt + 1
ReDim Preserve arfiles(2, cnt)
arfiles(0, cnt) = ""
arfiles(1, cnt) = arPath(level - 1)
arfiles(2, cnt) = level

Set oFolder = FSO.GetFolder(sPath)
Set oFiles = oFolder.Files
For Each oFile In oFiles
If oFile.Type = "Microsoft Excel Worksheet" Then
cnt = cnt + 1
ReDim Preserve arfiles(2, cnt)
arfiles(0, cnt) = oFolder.Path & "\" & oFile.Name
arfiles(1, cnt) = oFile.Name
arfiles(2, cnt) = level + 1
End If
Next oFile

level = level + 1
For Each oSubFolder In oFolder.Subfolders
SelectFiles oSubFolder.Path
Next
level = level - 1

End Sub

#If VBA6 Then
#Else
'-----------------------------**-----------------------------*-*------
Function Split(Text As String, _
Optional Delimiter As String = ",") As Variant
'-----------------------------**-----------------------------*-*------
Dim i As Long
Dim sFormula As String
Dim aryEval
Dim aryValues

If Delimiter = vbNullChar Then
Delimiter = Chr(7)
Text = Replace(Text, vbNullChar, Delimiter)
End If

sFormula = "{""" & Application.Substitute(Text, Delimiter, """,""") &
"""}"
aryEval = Evaluate(sFormula)
ReDim aryValues(0 To UBound(aryEval) - 1)
For i = 0 To UBound(aryValues)
aryValues(i) = aryEval(i + 1)
Next

Split = aryValues

End Function

'---------------------------------------------------------------------------
Public Function InStrRev(stringcheck As String, _
ByVal stringmatch As String, _
Optional ByVal start As Long = -1)
'---------------------------------------------------------------------------
Dim iStart As Long
Dim iLen As Long
Dim i As Long

If iStart = -1 Then
iStart = Len(stringcheck)
Else
iStart = start
End If

iLen = Len(stringmatch)

For i = iStart To 1 Step -1
If Mid(stringcheck, i, iLen) = stringmatch Then
InStrRev = i
Exit Function
End If
Next i
InStrRev = 0
End Function
'-----------------------------------------------------------------
#End If

--
HTH

Bob Phillips

(remove nothere from email address if mailing direct)

"m_ravindran"
wrote in message
...

Hi all,

Can anyone tell me a way to display all the names of xls files in a
folder in a separate spreadsheet?

Thanks in advance,

M.Ravindran

--
m_ravindran
------------------------------------------------------------------------
m_ravindran's Profile:
http://www.excelforum.com/member.php...o&userid=28668
View this thread: http://www.excelforum.com/showthread...hreadid=532881

Bob,
I tried your code and found it didn't (for me) display all the
subfolder names ALTHOUGH it displayed the content. I initialised sfolder as:

sFolder = "C:\Documents and Settings\John\My Documents\"

In the example below, it only displays the C:\Documents and Settings as
folders in columns A & B but displays the contents (of sudoku) in column C; I
was expecting "John" in Column C, "My Documents" in D, "sudoku" in E and
contents in F.

C:\Documents and Settings\John\My Documents\sudoku

In other cases, it will display more levels but never the last subfolder.

Have I done something wrong or do I not understand (more likely!) how it
works?

TIA

Toppers

"Bob Phillips" wrote:

This does all subfolders as well, and hyperlinks them

Option Explicit

Private cnt As Long
Private arfiles
Private level As Long

Sub Folders()
Dim i As Long
Dim sFolder As String
Dim iStart As Long
Dim iEnd As Long
Dim fOutline As Boolean

arfiles = Array()
cnt = -1
level = 1

sFolder = "E:\"
ReDim arfiles(2, 0)
If sFolder < "" Then
SelectFiles sFolder
Application.DisplayAlerts = False
On Error Resume Next
Worksheets("Files").Delete
On Error GoTo 0
Application.DisplayAlerts = True
Worksheets.Add.Name = "Files"
With ActiveSheet
For i = LBound(arfiles, 2) To UBound(arfiles, 2)
If arfiles(0, i) = "" Then
If fOutline Then
Rows(iStart + 1 & ":" & iEnd).Rows.Group
End If
With .Cells(i + 1, arfiles(2, i))
.Value = arfiles(1, i)
.Font.Bold = True
End With
iStart = i + 1
iEnd = iStart
fOutline = False
Else
.Hyperlinks.Add Anchor:=.Cells(i + 1, arfiles(2, i)), _
Address:=arfiles(0, i), _
TextToDisplay:=arfiles(1, i)
iEnd = iEnd + 1
fOutline = True
End If
Next
.Columns("A:Z").ColumnWidth = 5
End With
End If
'just in case there is another set to group
If fOutline Then
Rows(iStart + 1 & ":" & iEnd).Rows.Group
End If

Columns("A:Z").ColumnWidth = 5
ActiveSheet.Outline.ShowLevels RowLevels:=1
ActiveWindow.DisplayGridlines = False

End Sub

'-----------------------------------------------------------------------
Sub SelectFiles(Optional sPath As String)
'-----------------------------------------------------------------------
Static FSO As Object
Dim oSubFolder As Object
Dim oFolder As Object
Dim oFile As Object
Dim oFiles As Object
Dim arPath

If FSO Is Nothing Then
Set FSO = CreateObject("Scripting.FileSystemObject")
End If

If sPath = "" Then
sPath = CurDir
End If

arPath = Split(sPath, "\")
cnt = cnt + 1
ReDim Preserve arfiles(2, cnt)
arfiles(0, cnt) = ""
arfiles(1, cnt) = arPath(level - 1)
arfiles(2, cnt) = level

Set oFolder = FSO.GetFolder(sPath)
Set oFiles = oFolder.Files
For Each oFile In oFiles
If oFile.Type = "Microsoft Excel Worksheet" Then
cnt = cnt + 1
ReDim Preserve arfiles(2, cnt)
arfiles(0, cnt) = oFolder.Path & "\" & oFile.Name
arfiles(1, cnt) = oFile.Name
arfiles(2, cnt) = level + 1
End If
Next oFile

level = level + 1
For Each oSubFolder In oFolder.Subfolders
SelectFiles oSubFolder.Path
Next
level = level - 1

End Sub

#If VBA6 Then
#Else
'-----------------------------Â*Â*-----------------------------Â*-Â*------
Function Split(Text As String, _
Optional Delimiter As String = ",") As Variant
'-----------------------------Â*Â*-----------------------------Â*-Â*------
Dim i As Long
Dim sFormula As String
Dim aryEval
Dim aryValues

If Delimiter = vbNullChar Then
Delimiter = Chr(7)
Text = Replace(Text, vbNullChar, Delimiter)
End If

sFormula = "{""" & Application.Substitute(Text, Delimiter, """,""") &
"""}"
aryEval = Evaluate(sFormula)
ReDim aryValues(0 To UBound(aryEval) - 1)
For i = 0 To UBound(aryValues)
aryValues(i) = aryEval(i + 1)
Next

Split = aryValues

End Function

'---------------------------------------------------------------------------
Public Function InStrRev(stringcheck As String, _
ByVal stringmatch As String, _
Optional ByVal start As Long = -1)
'---------------------------------------------------------------------------
Dim iStart As Long
Dim iLen As Long
Dim i As Long

If iStart = -1 Then
iStart = Len(stringcheck)
Else
iStart = start
End If

iLen = Len(stringmatch)

For i = iStart To 1 Step -1
If Mid(stringcheck, i, iLen) = stringmatch Then
InStrRev = i
Exit Function
End If
Next i
InStrRev = 0
End Function
'-----------------------------------------------------------------
#End If

--
HTH

Bob Phillips

(remove nothere from email address if mailing direct)

"m_ravindran"
wrote in message
...

Hi all,

Can anyone tell me a way to display all the names of xls files in a
folder in a separate spreadsheet?

Thanks in advance,

M.Ravindran

--
m_ravindran
------------------------------------------------------------------------
m_ravindran's Profile:
http://www.excelforum.com/member.php...o&userid=28668
View this thread: http://www.excelforum.com/showthread...hreadid=532881

So Toppers is John is he?

I made a last minute change for woksheets only, and missed some I think.

Try this version and let me know if it again misses the last subfolder (do
you mean every last subfolder, or just the last one in the start folder?)

Option Explicit

Private cnt As Long
Private arfiles
Private level As Long

Sub Folders()
Dim i As Long
Dim sFolder As String
Dim iStart As Long
Dim iEnd As Long
Dim fOutline As Boolean

arfiles = Array()
cnt = -1
level = 1

sFolder = "C:\Documents and Settings\Bob\My Documents\"
ReDim arfiles(2, 0)
If sFolder < "" Then
SelectFiles sFolder
Application.DisplayAlerts = False
On Error Resume Next
Worksheets("Files").Delete
On Error GoTo 0
Application.DisplayAlerts = True
Worksheets.Add.Name = "Files"
With ActiveSheet
For i = LBound(arfiles, 2) To UBound(arfiles, 2)
If arfiles(0, i) = "" Then
If fOutline Then
Rows(iStart + 1 & ":" & iEnd).Rows.Group
End If
With .Cells(i + 1, arfiles(2, i))
.Value = arfiles(1, i)
.Font.Bold = True
End With
iStart = i + 1
iEnd = iStart
fOutline = False
Else
.Hyperlinks.Add Anchor:=.Cells(i + 1, arfiles(2, i)), _
Address:=arfiles(0, i), _
TextToDisplay:=arfiles(1, i)
iEnd = iEnd + 1
fOutline = True
End If
Next
.Columns("A:Z").ColumnWidth = 5
End With
End If
'just in case there is another set to group
If fOutline Then
Rows(iStart + 1 & ":" & iEnd).Rows.Group
End If

Columns("A:Z").ColumnWidth = 5
ActiveSheet.Outline.ShowLevels RowLevels:=1
ActiveWindow.DisplayGridlines = False

End Sub

'-----------------------------------------------------------------------
Sub SelectFiles(Optional sPath As String)
'-----------------------------------------------------------------------
Static FSO As Object
Dim oSubFolder As Object
Dim oFolder As Object
Dim oFile As Object
Dim oFiles As Object
Dim cFiles As Long
Dim arPath

If FSO Is Nothing Then
Set FSO = CreateObject("Scripting.FileSystemObject")
End If

If sPath = "" Then
sPath = CurDir
End If

arPath = Split(sPath, "\")
cnt = cnt + 1
ReDim Preserve arfiles(2, cnt)
arfiles(0, cnt) = ""
arfiles(1, cnt) = sPath
arfiles(2, cnt) = level

Set oFolder = FSO.GetFolder(sPath)
Set oFiles = oFolder.Files
cFiles = 0
For Each oFile In oFiles
If oFile.Type = "Microsoft Excel Worksheet" Then
cnt = cnt + 1
ReDim Preserve arfiles(2, cnt)
arfiles(0, cnt) = oFolder.Path & "\" & oFile.Name
arfiles(1, cnt) = oFile.Name
arfiles(2, cnt) = level + 1
cFiles = cFiles + 1
End If
Next oFile
If cFiles = 0 Then cnt = cnt - 1

level = level + 1
For Each oSubFolder In oFolder.Subfolders
SelectFiles oSubFolder.Path
Next
level = level - 1

End Sub

#If VBA6 Then
#Else
'-----------------------------**-----------------------------*-*------
Function Split(Text As String, _
Optional Delimiter As String = ",") As Variant
'-----------------------------**-----------------------------*-*------
Dim i As Long
Dim sFormula As String
Dim aryEval
Dim aryValues

If Delimiter = vbNullChar Then
Delimiter = Chr(7)
Text = Replace(Text, vbNullChar, Delimiter)
End If

sFormula = "{""" & Application.Substitute(Text, Delimiter, """,""") &
"""}"
aryEval = Evaluate(sFormula)
ReDim aryValues(0 To UBound(aryEval) - 1)
For i = 0 To UBound(aryValues)
aryValues(i) = aryEval(i + 1)
Next

Split = aryValues

End Function

'---------------------------------------------------------------------------
Public Function InStrRev(stringcheck As String, _
ByVal stringmatch As String, _
Optional ByVal start As Long = -1)
'---------------------------------------------------------------------------
Dim iStart As Long
Dim iLen As Long
Dim i As Long

If iStart = -1 Then
iStart = Len(stringcheck)
Else
iStart = start
End If

iLen = Len(stringmatch)

For i = iStart To 1 Step -1
If Mid(stringcheck, i, iLen) = stringmatch Then
InStrRev = i
Exit Function
End If
Next i
InStrRev = 0
End Function
'-----------------------------------------------------------------
#End If

--
HTH

Bob Phillips

(remove nothere from email address if mailing direct)

"Toppers" wrote in message
...
Bob,
I tried your code and found it didn't (for me) display all the
subfolder names ALTHOUGH it displayed the content. I initialised sfolder
as:

sFolder = "C:\Documents and Settings\John\My Documents\"

In the example below, it only displays the C:\Documents and Settings as
folders in columns A & B but displays the contents (of sudoku) in column
C; I
was expecting "John" in Column C, "My Documents" in D, "sudoku" in E and
contents in F.

C:\Documents and Settings\John\My Documents\sudoku

In other cases, it will display more levels but never the last subfolder.

Have I done something wrong or do I not understand (more likely!) how it
works?

TIA

Toppers

"Bob Phillips" wrote:

This does all subfolders as well, and hyperlinks them

Option Explicit

Private cnt As Long
Private arfiles
Private level As Long

Sub Folders()
Dim i As Long
Dim sFolder As String
Dim iStart As Long
Dim iEnd As Long
Dim fOutline As Boolean

arfiles = Array()
cnt = -1
level = 1

sFolder = "E:\"
ReDim arfiles(2, 0)
If sFolder < "" Then
SelectFiles sFolder
Application.DisplayAlerts = False
On Error Resume Next
Worksheets("Files").Delete
On Error GoTo 0
Application.DisplayAlerts = True
Worksheets.Add.Name = "Files"
With ActiveSheet
For i = LBound(arfiles, 2) To UBound(arfiles, 2)
If arfiles(0, i) = "" Then
If fOutline Then
Rows(iStart + 1 & ":" & iEnd).Rows.Group
End If
With .Cells(i + 1, arfiles(2, i))
.Value = arfiles(1, i)
.Font.Bold = True
End With
iStart = i + 1
iEnd = iStart
fOutline = False
Else
.Hyperlinks.Add Anchor:=.Cells(i + 1, arfiles(2,
i)), _
Address:=arfiles(0, i), _
TextToDisplay:=arfiles(1, i)
iEnd = iEnd + 1
fOutline = True
End If
Next
.Columns("A:Z").ColumnWidth = 5
End With
End If
'just in case there is another set to group
If fOutline Then
Rows(iStart + 1 & ":" & iEnd).Rows.Group
End If

Columns("A:Z").ColumnWidth = 5
ActiveSheet.Outline.ShowLevels RowLevels:=1
ActiveWindow.DisplayGridlines = False

End Sub

'-----------------------------------------------------------------------
Sub SelectFiles(Optional sPath As String)
'-----------------------------------------------------------------------
Static FSO As Object
Dim oSubFolder As Object
Dim oFolder As Object
Dim oFile As Object
Dim oFiles As Object
Dim arPath

If FSO Is Nothing Then
Set FSO = CreateObject("Scripting.FileSystemObject")
End If

If sPath = "" Then
sPath = CurDir
End If

arPath = Split(sPath, "\")
cnt = cnt + 1
ReDim Preserve arfiles(2, cnt)
arfiles(0, cnt) = ""
arfiles(1, cnt) = arPath(level - 1)
arfiles(2, cnt) = level

Set oFolder = FSO.GetFolder(sPath)
Set oFiles = oFolder.Files
For Each oFile In oFiles
If oFile.Type = "Microsoft Excel Worksheet" Then
cnt = cnt + 1
ReDim Preserve arfiles(2, cnt)
arfiles(0, cnt) = oFolder.Path & "\" & oFile.Name
arfiles(1, cnt) = oFile.Name
arfiles(2, cnt) = level + 1
End If
Next oFile

level = level + 1
For Each oSubFolder In oFolder.Subfolders
SelectFiles oSubFolder.Path
Next
level = level - 1

End Sub

#If VBA6 Then
#Else
'-----------------------------**-----------------------------*-*------
Function Split(Text As String, _
Optional Delimiter As String = ",") As Variant
'-----------------------------**-----------------------------*-*------
Dim i As Long
Dim sFormula As String
Dim aryEval
Dim aryValues

If Delimiter = vbNullChar Then
Delimiter = Chr(7)
Text = Replace(Text, vbNullChar, Delimiter)
End If

sFormula = "{""" & Application.Substitute(Text, Delimiter, """,""")
&
"""}"
aryEval = Evaluate(sFormula)
ReDim aryValues(0 To UBound(aryEval) - 1)
For i = 0 To UBound(aryValues)
aryValues(i) = aryEval(i + 1)
Next

Split = aryValues

End Function

'---------------------------------------------------------------------------
Public Function InStrRev(stringcheck As String, _
ByVal stringmatch As String, _
Optional ByVal start As Long = -1)

'---------------------------------------------------------------------------
Dim iStart As Long
Dim iLen As Long
Dim i As Long

If iStart = -1 Then
iStart = Len(stringcheck)
Else
iStart = start
End If

iLen = Len(stringmatch)

For i = iStart To 1 Step -1
If Mid(stringcheck, i, iLen) = stringmatch Then
InStrRev = i
Exit Function
End If
Next i
InStrRev = 0
End Function
'-----------------------------------------------------------------
#End If

--
HTH

Bob Phillips

(remove nothere from email address if mailing direct)

"m_ravindran"
wrote in message
...

Hi all,

Can anyone tell me a way to display all the names of xls files in a
folder in a separate spreadsheet?

Thanks in advance,

M.Ravindran

--
m_ravindran

------------------------------------------------------------------------
m_ravindran's Profile:
http://www.excelforum.com/member.php...o&userid=28668
View this thread:
http://www.excelforum.com/showthread...hreadid=532881

Bob,
Many thanks for the update which now does what I expected. I
haven't checked everything in minute detail but a random sample was 100%
correct so I am sure the whole is 100% OK.

Again, thanks for the correction ... much appreciated.

John "Toppers"!

"Bob Phillips" wrote:

So Toppers is John is he?

I made a last minute change for woksheets only, and missed some I think.

Try this version and let me know if it again misses the last subfolder (do
you mean every last subfolder, or just the last one in the start folder?)

Option Explicit

Private cnt As Long
Private arfiles
Private level As Long

Sub Folders()
Dim i As Long
Dim sFolder As String
Dim iStart As Long
Dim iEnd As Long
Dim fOutline As Boolean

arfiles = Array()
cnt = -1
level = 1

sFolder = "C:\Documents and Settings\Bob\My Documents\"
ReDim arfiles(2, 0)
If sFolder < "" Then
SelectFiles sFolder
Application.DisplayAlerts = False
On Error Resume Next
Worksheets("Files").Delete
On Error GoTo 0
Application.DisplayAlerts = True
Worksheets.Add.Name = "Files"
With ActiveSheet
For i = LBound(arfiles, 2) To UBound(arfiles, 2)
If arfiles(0, i) = "" Then
If fOutline Then
Rows(iStart + 1 & ":" & iEnd).Rows.Group
End If
With .Cells(i + 1, arfiles(2, i))
.Value = arfiles(1, i)
.Font.Bold = True
End With
iStart = i + 1
iEnd = iStart
fOutline = False
Else
.Hyperlinks.Add Anchor:=.Cells(i + 1, arfiles(2, i)), _
Address:=arfiles(0, i), _
TextToDisplay:=arfiles(1, i)
iEnd = iEnd + 1
fOutline = True
End If
Next
.Columns("A:Z").ColumnWidth = 5
End With
End If
'just in case there is another set to group
If fOutline Then
Rows(iStart + 1 & ":" & iEnd).Rows.Group
End If

Columns("A:Z").ColumnWidth = 5
ActiveSheet.Outline.ShowLevels RowLevels:=1
ActiveWindow.DisplayGridlines = False

End Sub

'-----------------------------------------------------------------------
Sub SelectFiles(Optional sPath As String)
'-----------------------------------------------------------------------
Static FSO As Object
Dim oSubFolder As Object
Dim oFolder As Object
Dim oFile As Object
Dim oFiles As Object
Dim cFiles As Long
Dim arPath

If FSO Is Nothing Then
Set FSO = CreateObject("Scripting.FileSystemObject")
End If

If sPath = "" Then
sPath = CurDir
End If

arPath = Split(sPath, "\")
cnt = cnt + 1
ReDim Preserve arfiles(2, cnt)
arfiles(0, cnt) = ""
arfiles(1, cnt) = sPath
arfiles(2, cnt) = level

Set oFolder = FSO.GetFolder(sPath)
Set oFiles = oFolder.Files
cFiles = 0
For Each oFile In oFiles
If oFile.Type = "Microsoft Excel Worksheet" Then
cnt = cnt + 1
ReDim Preserve arfiles(2, cnt)
arfiles(0, cnt) = oFolder.Path & "\" & oFile.Name
arfiles(1, cnt) = oFile.Name
arfiles(2, cnt) = level + 1
cFiles = cFiles + 1
End If
Next oFile
If cFiles = 0 Then cnt = cnt - 1

level = level + 1
For Each oSubFolder In oFolder.Subfolders
SelectFiles oSubFolder.Path
Next
level = level - 1

End Sub

#If VBA6 Then
#Else
'-----------------------------Â*Â*-----------------------------Â*-Â*------
Function Split(Text As String, _
Optional Delimiter As String = ",") As Variant
'-----------------------------Â*Â*-----------------------------Â*-Â*------
Dim i As Long
Dim sFormula As String
Dim aryEval
Dim aryValues

If Delimiter = vbNullChar Then
Delimiter = Chr(7)
Text = Replace(Text, vbNullChar, Delimiter)
End If

sFormula = "{""" & Application.Substitute(Text, Delimiter, """,""") &
"""}"
aryEval = Evaluate(sFormula)
ReDim aryValues(0 To UBound(aryEval) - 1)
For i = 0 To UBound(aryValues)
aryValues(i) = aryEval(i + 1)
Next

Split = aryValues

End Function

'---------------------------------------------------------------------------
Public Function InStrRev(stringcheck As String, _
ByVal stringmatch As String, _
Optional ByVal start As Long = -1)
'---------------------------------------------------------------------------
Dim iStart As Long
Dim iLen As Long
Dim i As Long

If iStart = -1 Then
iStart = Len(stringcheck)
Else
iStart = start
End If

iLen = Len(stringmatch)

For i = iStart To 1 Step -1
If Mid(stringcheck, i, iLen) = stringmatch Then
InStrRev = i
Exit Function
End If
Next i
InStrRev = 0
End Function
'-----------------------------------------------------------------
#End If

--
HTH

Bob Phillips

(remove nothere from email address if mailing direct)

"Toppers" wrote in message
...
Bob,
I tried your code and found it didn't (for me) display all the
subfolder names ALTHOUGH it displayed the content. I initialised sfolder
as:

sFolder = "C:\Documents and Settings\John\My Documents\"

In the example below, it only displays the C:\Documents and Settings as
folders in columns A & B but displays the contents (of sudoku) in column
C; I
was expecting "John" in Column C, "My Documents" in D, "sudoku" in E and
contents in F.

C:\Documents and Settings\John\My Documents\sudoku

In other cases, it will display more levels but never the last subfolder.

Have I done something wrong or do I not understand (more likely!) how it
works?

TIA

Toppers

"Bob Phillips" wrote:

This does all subfolders as well, and hyperlinks them

Option Explicit

Private cnt As Long
Private arfiles
Private level As Long

Sub Folders()
Dim i As Long
Dim sFolder As String
Dim iStart As Long
Dim iEnd As Long
Dim fOutline As Boolean

arfiles = Array()
cnt = -1
level = 1

sFolder = "E:\"
ReDim arfiles(2, 0)
If sFolder < "" Then
SelectFiles sFolder
Application.DisplayAlerts = False
On Error Resume Next
Worksheets("Files").Delete
On Error GoTo 0
Application.DisplayAlerts = True
Worksheets.Add.Name = "Files"
With ActiveSheet
For i = LBound(arfiles, 2) To UBound(arfiles, 2)
If arfiles(0, i) = "" Then
If fOutline Then
Rows(iStart + 1 & ":" & iEnd).Rows.Group
End If
With .Cells(i + 1, arfiles(2, i))
.Value = arfiles(1, i)
.Font.Bold = True
End With
iStart = i + 1
iEnd = iStart
fOutline = False
Else
.Hyperlinks.Add Anchor:=.Cells(i + 1, arfiles(2,
i)), _
Address:=arfiles(0, i), _
TextToDisplay:=arfiles(1, i)
iEnd = iEnd + 1
fOutline = True
End If
Next
.Columns("A:Z").ColumnWidth = 5
End With
End If
'just in case there is another set to group
If fOutline Then
Rows(iStart + 1 & ":" & iEnd).Rows.Group
End If

Columns("A:Z").ColumnWidth = 5
ActiveSheet.Outline.ShowLevels RowLevels:=1
ActiveWindow.DisplayGridlines = False

End Sub

'-----------------------------------------------------------------------
Sub SelectFiles(Optional sPath As String)
'-----------------------------------------------------------------------
Static FSO As Object
Dim oSubFolder As Object
Dim oFolder As Object
Dim oFile As Object
Dim oFiles As Object
Dim arPath

If FSO Is Nothing Then
Set FSO = CreateObject("Scripting.FileSystemObject")
End If

If sPath = "" Then
sPath = CurDir
End If

arPath = Split(sPath, "\")
cnt = cnt + 1
ReDim Preserve arfiles(2, cnt)
arfiles(0, cnt) = ""

Nice to know the name John.

Regards

Bob

"Toppers" wrote in message
...
Bob,
Many thanks for the update which now does what I expected. I
haven't checked everything in minute detail but a random sample was 100%
correct so I am sure the whole is 100% OK.

Again, thanks for the correction ... much appreciated.

John "Toppers"!

"Bob Phillips" wrote:

So Toppers is John is he?

I made a last minute change for woksheets only, and missed some I think.

Try this version and let me know if it again misses the last subfolder
(do
you mean every last subfolder, or just the last one in the start
folder?)

Option Explicit

Private cnt As Long
Private arfiles
Private level As Long

Sub Folders()
Dim i As Long
Dim sFolder As String
Dim iStart As Long
Dim iEnd As Long
Dim fOutline As Boolean

arfiles = Array()
cnt = -1
level = 1

sFolder = "C:\Documents and Settings\Bob\My Documents\"
ReDim arfiles(2, 0)
If sFolder < "" Then
SelectFiles sFolder
Application.DisplayAlerts = False
On Error Resume Next
Worksheets("Files").Delete
On Error GoTo 0
Application.DisplayAlerts = True
Worksheets.Add.Name = "Files"
With ActiveSheet
For i = LBound(arfiles, 2) To UBound(arfiles, 2)
If arfiles(0, i) = "" Then
If fOutline Then
Rows(iStart + 1 & ":" & iEnd).Rows.Group
End If
With .Cells(i + 1, arfiles(2, i))
.Value = arfiles(1, i)
.Font.Bold = True
End With
iStart = i + 1
iEnd = iStart
fOutline = False
Else
.Hyperlinks.Add Anchor:=.Cells(i + 1, arfiles(2,
i)), _
Address:=arfiles(0, i), _
TextToDisplay:=arfiles(1, i)
iEnd = iEnd + 1
fOutline = True
End If
Next
.Columns("A:Z").ColumnWidth = 5
End With
End If
'just in case there is another set to group
If fOutline Then
Rows(iStart + 1 & ":" & iEnd).Rows.Group
End If

Columns("A:Z").ColumnWidth = 5
ActiveSheet.Outline.ShowLevels RowLevels:=1
ActiveWindow.DisplayGridlines = False

End Sub

'-----------------------------------------------------------------------
Sub SelectFiles(Optional sPath As String)
'-----------------------------------------------------------------------
Static FSO As Object
Dim oSubFolder As Object
Dim oFolder As Object
Dim oFile As Object
Dim oFiles As Object
Dim cFiles As Long
Dim arPath

If FSO Is Nothing Then
Set FSO = CreateObject("Scripting.FileSystemObject")
End If

If sPath = "" Then
sPath = CurDir
End If

arPath = Split(sPath, "\")
cnt = cnt + 1
ReDim Preserve arfiles(2, cnt)
arfiles(0, cnt) = ""
arfiles(1, cnt) = sPath
arfiles(2, cnt) = level

Set oFolder = FSO.GetFolder(sPath)
Set oFiles = oFolder.Files
cFiles = 0
For Each oFile In oFiles
If oFile.Type = "Microsoft Excel Worksheet" Then
cnt = cnt + 1
ReDim Preserve arfiles(2, cnt)
arfiles(0, cnt) = oFolder.Path & "\" & oFile.Name
arfiles(1, cnt) = oFile.Name
arfiles(2, cnt) = level + 1
cFiles = cFiles + 1
End If
Next oFile
If cFiles = 0 Then cnt = cnt - 1

level = level + 1
For Each oSubFolder In oFolder.Subfolders
SelectFiles oSubFolder.Path
Next
level = level - 1

End Sub

#If VBA6 Then
#Else
'-----------------------------**-----------------------------*-*------
Function Split(Text As String, _
Optional Delimiter As String = ",") As Variant
'-----------------------------**-----------------------------*-*------
Dim i As Long
Dim sFormula As String
Dim aryEval
Dim aryValues

If Delimiter = vbNullChar Then
Delimiter = Chr(7)
Text = Replace(Text, vbNullChar, Delimiter)
End If

sFormula = "{""" & Application.Substitute(Text, Delimiter, """,""")
&
"""}"
aryEval = Evaluate(sFormula)
ReDim aryValues(0 To UBound(aryEval) - 1)
For i = 0 To UBound(aryValues)
aryValues(i) = aryEval(i + 1)
Next

Split = aryValues

End Function

'---------------------------------------------------------------------------
Public Function InStrRev(stringcheck As String, _
ByVal stringmatch As String, _
Optional ByVal start As Long = -1)

'---------------------------------------------------------------------------
Dim iStart As Long
Dim iLen As Long
Dim i As Long

If iStart = -1 Then
iStart = Len(stringcheck)
Else
iStart = start
End If

iLen = Len(stringmatch)

For i = iStart To 1 Step -1
If Mid(stringcheck, i, iLen) = stringmatch Then
InStrRev = i
Exit Function
End If
Next i
InStrRev = 0
End Function
'-----------------------------------------------------------------
#End If

--
HTH

Bob Phillips

(remove nothere from email address if mailing direct)

"Toppers" wrote in message
...
Bob,
I tried your code and found it didn't (for me) display all
the
subfolder names ALTHOUGH it displayed the content. I initialised
sfolder
as:

sFolder = "C:\Documents and Settings\John\My Documents\"

In the example below, it only displays the C:\Documents and Settings
as
folders in columns A & B but displays the contents (of sudoku) in
column
C; I
was expecting "John" in Column C, "My Documents" in D, "sudoku" in E
and
contents in F.

C:\Documents and Settings\John\My Documents\sudoku

In other cases, it will display more levels but never the last
subfolder.

Have I done something wrong or do I not understand (more likely!) how
it
works?

TIA

Toppers

"Bob Phillips" wrote:

This does all subfolders as well, and hyperlinks them

Option Explicit

Private cnt As Long
Private arfiles
Private level As Long

Sub Folders()
Dim i As Long
Dim sFolder As String
Dim iStart As Long
Dim iEnd As Long
Dim fOutline As Boolean

arfiles = Array()
cnt = -1
level = 1

sFolder = "E:\"
ReDim arfiles(2, 0)
If sFolder < "" Then
SelectFiles sFolder
Application.DisplayAlerts = False
On Error Resume Next
Worksheets("Files").Delete
On Error GoTo 0
Application.DisplayAlerts = True
Worksheets.Add.Name = "Files"
With ActiveSheet
For i = LBound(arfiles, 2) To UBound(arfiles, 2)
If arfiles(0, i) = "" Then
If fOutline Then
Rows(iStart + 1 & ":" & iEnd).Rows.Group
End If
With .Cells(i + 1, arfiles(2, i))
.Value = arfiles(1, i)
.Font.Bold = True
End With
iStart = i + 1
iEnd = iStart
fOutline = False
Else
.Hyperlinks.Add Anchor:=.Cells(i + 1, arfiles(2,
i)), _
Address:=arfiles(0, i), _
TextToDisplay:=arfiles(1, i)
iEnd = iEnd + 1
fOutline = True
End If
Next
.Columns("A:Z").ColumnWidth = 5
End With
End If
'just in case there is another set to group
If fOutline Then
Rows(iStart + 1 & ":" & iEnd).Rows.Group
End If

Columns("A:Z").ColumnWidth = 5
ActiveSheet.Outline.ShowLevels RowLevels:=1
ActiveWindow.DisplayGridlines = False

End Sub

'-----------------------------------------------------------------------
Sub SelectFiles(Optional sPath As String)

'-----------------------------------------------------------------------
Static FSO As Object
Dim oSubFolder As Object
Dim oFolder As Object
Dim oFile As Object
Dim oFiles As Object
Dim arPath

If FSO Is Nothing Then
Set FSO = CreateObject("Scripting.FileSystemObject")
End If

If sPath = "" Then
sPath = CurDir
End If

arPath = Split(sPath, "\")
cnt = cnt + 1
ReDim Preserve arfiles(2, cnt)
arfiles(0, cnt) = ""