Hi!

Could someone tell me whats wrong with these codes?


Sub FileList()
Dim File As Variant
With Application.FileSearch
.LookIn = "C:\"
.FileType = msoFileTypeAllFiles
.Execute
For Each File In .FoundFiles
MsgBox File
Next File
End With
End Sub

Run Time Error 445 - Object does not support this action!

Thanks

Hi,

This works fine in Excel 2003 so are you using something else. I understand
from other posts Excel 2007 doesn't support Filesearch.

Have a look at this thread.

http://groups.google.com/group/micro...03da44cc?hl=en


Mike

"Varne" wrote:

Hi!

Could someone tell me whats wrong with these codes?


Sub FileList()
Dim File As Variant
With Application.FileSearch
.LookIn = "C:\"
.FileType = msoFileTypeAllFiles
.Execute
For Each File In .FoundFiles
MsgBox File
Next File
End With
End Sub

Run Time Error 445 - Object does not support this action!

Thanks

Worked okay for me.

--
__________________________________
HTH

Bob

"Varne" wrote in message
...
Hi!

Could someone tell me whats wrong with these codes?


Sub FileList()
Dim File As Variant
With Application.FileSearch
.LookIn = "C:\"
.FileType = msoFileTypeAllFiles
.Execute
For Each File In .FoundFiles
MsgBox File
Next File
End With
End Sub

Run Time Error 445 - Object does not support this action!

Thanks

You code works fine!
(as long as you avoid using Excel 2007)
--
Gary''s Student - gsnu200852


"Varne" wrote:

Hi!

Could someone tell me whats wrong with these codes?


Sub FileList()
Dim File As Variant
With Application.FileSearch
.LookIn = "C:\"
.FileType = msoFileTypeAllFiles
.Execute
For Each File In .FoundFiles
MsgBox File
Next File
End With
End Sub

Run Time Error 445 - Object does not support this action!

Thanks

Works find in 2003..You must be using 2007. Try the below

Sub FileList()
Dim strFile As string
Dim strFolder As string
strFolder = "c:\"

strFile = Dir("c:\*.*", vbNormal)
Do While strFile < ""
MsgBox strFolder & strFile
strFile = Dir
Loop
End Sub

If this post helps click Yes
---------------
Jacob Skaria


"Varne" wrote:

Hi!

Could someone tell me whats wrong with these codes?


Sub FileList()
Dim File As Variant
With Application.FileSearch
.LookIn = "C:\"
.FileType = msoFileTypeAllFiles
.Execute
For Each File In .FoundFiles
MsgBox File
Next File
End With
End Sub

Run Time Error 445 - Object does not support this action!

Thanks

Thanks everyone. I used a 2007 Excel application.

Jacob. Special thanks to you. Your codes do the list.

M Varnendra

"Jacob Skaria" wrote:

Works find in 2003..You must be using 2007. Try the below

Sub FileList()
Dim strFile As string
Dim strFolder As string
strFolder = "c:\"

strFile = Dir("c:\*.*", vbNormal)
Do While strFile < ""
MsgBox strFolder & strFile
strFile = Dir
Loop
End Sub

If this post helps click Yes
---------------
Jacob Skaria


"Varne" wrote:

Hi!

Could someone tell me whats wrong with these codes?


Sub FileList()
Dim File As Variant
With Application.FileSearch
.LookIn = "C:\"
.FileType = msoFileTypeAllFiles
.Execute
For Each File In .FoundFiles
MsgBox File
Next File
End With
End Sub

Run Time Error 445 - Object does not support this action!

Thanks

For future questions you might ask... it is always a good idea to mention
the version of Excel you are using.

--
Rick (MVP - Excel)


"Varne" wrote in message
...
Thanks everyone. I used a 2007 Excel application.

Jacob. Special thanks to you. Your codes do the list.

M Varnendra

"Jacob Skaria" wrote:

Works find in 2003..You must be using 2007. Try the below

Sub FileList()
Dim strFile As string
Dim strFolder As string
strFolder = "c:\"

strFile = Dir("c:\*.*", vbNormal)
Do While strFile < ""
MsgBox strFolder & strFile
strFile = Dir
Loop
End Sub

If this post helps click Yes
---------------
Jacob Skaria


"Varne" wrote:

Hi!

Could someone tell me whats wrong with these codes?


Sub FileList()
Dim File As Variant
With Application.FileSearch
.LookIn = "C:\"
.FileType = msoFileTypeAllFiles
.Execute
For Each File In .FoundFiles
MsgBox File
Next File
End With
End Sub

Run Time Error 445 - Object does not support this action!

Thanks

Do you know how to get at subfolders w/ 2007? This example only looks at the
current folder but not any subfolders under it.
--
Sincerely,
Gary Brown



"Jacob Skaria" wrote:

Works find in 2003..You must be using 2007. Try the below

Sub FileList()
Dim strFile As string
Dim strFolder As string
strFolder = "c:\"

strFile = Dir("c:\*.*", vbNormal)
Do While strFile < ""
MsgBox strFolder & strFile
strFile = Dir
Loop
End Sub

If this post helps click Yes
---------------
Jacob Skaria


"Varne" wrote:

Hi!

Could someone tell me whats wrong with these codes?


Sub FileList()
Dim File As Variant
With Application.FileSearch
.LookIn = "C:\"
.FileType = msoFileTypeAllFiles
.Execute
For Each File In .FoundFiles
MsgBox File
Next File
End With
End Sub

Run Time Error 445 - Object does not support this action!

Thanks

Thanks for your feedback
A small change.. replaced c:\ with strFolder

Sub FileList()
Dim strFile As string
Dim strFolder As string
strFolder = "c:\"

strFile = Dir(strFolder & "*.*", vbNormal)
Do While strFile < ""
MsgBox strFolder & strFile
strFile = Dir
Loop
End Sub

--
If this post helps click Yes
---------------
Jacob Skaria


"Varne" wrote:

Thanks everyone. I used a 2007 Excel application.

Jacob. Special thanks to you. Your codes do the list.

M Varnendra

"Jacob Skaria" wrote:

Works find in 2003..You must be using 2007. Try the below

Sub FileList()
Dim strFile As string
Dim strFolder As string
strFolder = "c:\"

strFile = Dir("c:\*.*", vbNormal)
Do While strFile < ""
MsgBox strFolder & strFile
strFile = Dir
Loop
End Sub

If this post helps click Yes
---------------
Jacob Skaria


"Varne" wrote:

Hi!

Could someone tell me whats wrong with these codes?


Sub FileList()
Dim File As Variant
With Application.FileSearch
.LookIn = "C:\"
.FileType = msoFileTypeAllFiles
.Execute
For Each File In .FoundFiles
MsgBox File
Next File
End With
End Sub

Run Time Error 445 - Object does not support this action!

Thanks

Dear Rick

I am sorry. When replying it did not occur I was going to annoy senior
Programmers. I am very sorry. For future questions I will clearly state the
Excel version.

Yours Sincerely
M Varnendra

"Rick Rothstein" wrote:

For future questions you might ask... it is always a good idea to mention
the version of Excel you are using.

--
Rick (MVP - Excel)


"Varne" wrote in message
...
Thanks everyone. I used a 2007 Excel application.

Jacob. Special thanks to you. Your codes do the list.

M Varnendra

"Jacob Skaria" wrote:

Works find in 2003..You must be using 2007. Try the below

Sub FileList()
Dim strFile As string
Dim strFolder As string
strFolder = "c:\"

strFile = Dir("c:\*.*", vbNormal)
Do While strFile < ""
MsgBox strFolder & strFile
strFile = Dir
Loop
End Sub

If this post helps click Yes
---------------
Jacob Skaria


"Varne" wrote:

Hi!

Could someone tell me whats wrong with these codes?


Sub FileList()
Dim File As Variant
With Application.FileSearch
.LookIn = "C:\"
.FileType = msoFileTypeAllFiles
.Execute
For Each File In .FoundFiles
MsgBox File
Next File
End With
End Sub

Run Time Error 445 - Object does not support this action!

Thanks

It is not that you annoyed anyone... its just that it makes it easier for us
to be able to give you a timely answer that you can actually use (as you can
see from this question of yours... it can make a difference which version of
Excel you are using).

--
Rick (MVP - Excel)


"Varne" wrote in message
...
Dear Rick

I am sorry. When replying it did not occur I was going to annoy senior
Programmers. I am very sorry. For future questions I will clearly state
the
Excel version.

Yours Sincerely
M Varnendra

"Rick Rothstein" wrote:

For future questions you might ask... it is always a good idea to mention
the version of Excel you are using.

--
Rick (MVP - Excel)


"Varne" wrote in message
...
Thanks everyone. I used a 2007 Excel application.

Jacob. Special thanks to you. Your codes do the list.

M Varnendra

"Jacob Skaria" wrote:

Works find in 2003..You must be using 2007. Try the below

Sub FileList()
Dim strFile As string
Dim strFolder As string
strFolder = "c:\"

strFile = Dir("c:\*.*", vbNormal)
Do While strFile < ""
MsgBox strFolder & strFile
strFile = Dir
Loop
End Sub

If this post helps click Yes
---------------
Jacob Skaria


"Varne" wrote:

Hi!

Could someone tell me whats wrong with these codes?


Sub FileList()
Dim File As Variant
With Application.FileSearch
.LookIn = "C:\"
.FileType = msoFileTypeAllFiles
.Execute
For Each File In .FoundFiles
MsgBox File
Next File
End With
End Sub

Run Time Error 445 - Object does not support this action!

Thanks

Hi Gary

I will try it. If it works I will load it down here. If not I will let you
know?

Write to you soon

M Varnendra

"Gary Brown" wrote:

Do you know how to get at subfolders w/ 2007? This example only looks at the
current folder but not any subfolders under it.
--
Sincerely,
Gary Brown



"Jacob Skaria" wrote:

Works find in 2003..You must be using 2007. Try the below

Sub FileList()
Dim strFile As string
Dim strFolder As string
strFolder = "c:\"

strFile = Dir("c:\*.*", vbNormal)
Do While strFile < ""
MsgBox strFolder & strFile
strFile = Dir
Loop
End Sub

If this post helps click Yes
---------------
Jacob Skaria


"Varne" wrote:

Hi!

Could someone tell me whats wrong with these codes?


Sub FileList()
Dim File As Variant
With Application.FileSearch
.LookIn = "C:\"
.FileType = msoFileTypeAllFiles
.Execute
For Each File In .FoundFiles
MsgBox File
Next File
End With
End Sub

Run Time Error 445 - Object does not support this action!

Thanks

Hi Gary

For a full check up of files in any particular directory first I would
adjust (16 for vb normal and listing for box messaging) and run the above
codes and then would use len and mid fuctions to siphon out the sub
directories and then run the above codes for each sub directory.

I will do it on 16th evening (UK) and load it on 17th. If there is a better
way please give a clue.


Kind Regards
M Varnendra
"Varne" wrote:

Hi Gary

I will try it. If it works I will load it down here. If not I will let you
know?

Write to you soon

M Varnendra

"Gary Brown" wrote:

Do you know how to get at subfolders w/ 2007? This example only looks at the
current folder but not any subfolders under it.
--
Sincerely,
Gary Brown



"Jacob Skaria" wrote:

Works find in 2003..You must be using 2007. Try the below

Sub FileList()
Dim strFile As string
Dim strFolder As string
strFolder = "c:\"

strFile = Dir("c:\*.*", vbNormal)
Do While strFile < ""
MsgBox strFolder & strFile
strFile = Dir
Loop
End Sub

If this post helps click Yes
---------------
Jacob Skaria


"Varne" wrote:

Hi!

Could someone tell me whats wrong with these codes?


Sub FileList()
Dim File As Variant
With Application.FileSearch
.LookIn = "C:\"
.FileType = msoFileTypeAllFiles
.Execute
For Each File In .FoundFiles
MsgBox File
Next File
End With
End Sub

Run Time Error 445 - Object does not support this action!

Thanks

Hi Gary

I wrote some codes (given below) for listing sub folders and files in a
Folder. It can be expanded to several levels. I stoped with the first level
sub folder. However it has a few problems like not reading certain sub folder
- If I expand C:\ and then try to expand the sub folders it does not work but
it expands all subfolders in Documents.

Surely there must be a better way. If you know please show me how to do it.

My Work;

Dim StartFolder As String
Dim InputBoxForInteraction As String
Dim InputBoxForStipulatingFolders As String

Sub HeadProcedure()

'Frmatting for New Start
Range("a1:z1000").ClearContents
Columns("a:z").ColumnWidth = 8.43
Cells(1, 1).Select

'Start Folder Expansion
Application.ScreenUpdating = False
InputBoxForStipulatingFolders = Application.InputBox(prompt:="Write Folder
Path leaving out the backslash at the end", Type:=2)
If InputBoxForStipulatingFolders = "" Then '2
Exit Sub
End If '-2
StartFolder = InputBoxForStipulatingFolders & "\"
ActiveCell = StartFolder
Call ListSubFoldersAndFiles(s)
If Cells(2, 2) = "" Then '6
Cells(1, 1).ClearContents
MsgBox "Incorrect Folder Path Description", vbInformation
Cells(1, 1).Select
Columns("a:j").EntireColumn.AutoFit
Exit Sub
End If '-6
Columns("a:j").EntireColumn.AutoFit
Application.ScreenUpdating = True
Application.ScreenUpdating = False
Cells(1, 1).Select
Application.ScreenUpdating = True

'Level 1 Folders Expansion
Application.ScreenUpdating = False
InputBoxForInteraction = Application.InputBox(prompt:="Say 'Yes' if you want
to see the contents of any Level Folders", Type:=2)
If InputBoxForInteraction = "Yes" Then '24
InputBoxForStipulatingFolders = Application.InputBox(prompt:="Write Level 1
Sub Folder Name leaving out the backslash at the end ", Type:=2)
StartFolder = InputBoxForStipulatingFolders & "\"
Call Level1FolderFinder(s)
If Cells(1, 2) = 1 Then '4
Cells(1, 2).ClearContents
MsgBox "Folder Name Incorrect"
Exit Sub
End If '-4
Call ListSubFoldersAndFiles(s)
Call Level1FolderFinder(s)
ActiveCell.Offset(1, 0).Select
If Not ActiveCell.Offset(0, 1) = "" Then '9
Range(Selection, ActiveCell.Offset(1000, 0)).Select
Selection.Cut
Do '2
ActiveCell.Offset(1, 0).Select
Loop Until ActiveCell.Offset(0, 1) = "" '-2
ActiveSheet.Paste
Cells(1, 1).Select
Else
Call RemovingBackSlash(s)
Cells(1, 1).Select
MsgBox "No Contents in " & StartFolder
End If '-9
End If '-24

Columns("a:j").EntireColumn.AutoFit

End Sub

Sub ListSubFoldersAndFiles(s)

Dim ReadFile As String

ReadFile = Dir(StartFolder & "*.*", 16)
ActiveCell.Offset(1, 1).Select
ActiveCell = ReadFile

Do While ReadFile < "" '4
Call RemovingPoint(s)
ReadFile = Dir
ActiveCell = ReadFile
Loop '-4

End Sub

Sub RemovingPoint(s)

Dim LoopLookingForPoint As Integer

For LoopLookingForPoint = Len(ActiveCell) To 1 Step -1 '6
If Not Mid$(ActiveCell, LoopLookingForPoint, 1) = "." Then '-4
Call TaggingSubFolders(s)
ActiveCell.Offset(1, 0).Select
Exit Sub
End If '-4
Next '-6
ActiveCell.ClearContents

End Sub

Sub TaggingSubFolders(s)

Dim LoopLookingForSubFolders

For LoopLookingForFolders = Len(ActiveCell) To 1 Step -1 '4
If Mid$(ActiveCell, LoopLookingForFolders, 1) = "." Then '2
Exit Sub
End If '-2
Next '-4
ActiveCell = ActiveCell & "\"

End Sub

Sub Level1FolderFinder(s)

Cells(1, 2).Select
Do '8
ActiveCell.Offset(1, 0).Select
A = A + 1
If A = 1000 Then '4
Cells(1, 2).Select
ActiveCell = 1
Exit Sub
End If '-4
Loop Until ActiveCell = StartFolder '- 8

End Sub

Sub RemovingBackSlash(s)

Dim LoopLookingForBackSlash As Integer

ActiveCell.Offset(-1, 0).Select
ActiveCell.Offset(0, 1) = ActiveCell
For LoopLookingForBackSlash = Len(ActiveCell.Offset(0, 1)) To 1 Step -1 '6
If Mid$(ActiveCell.Offset(0, 1), LoopLookingForBackSlash, 1) = "\" Then '4
ActiveCell.Offset(0, 1).Characters(LoopLookingForBackSlash).Delete
StartFolder = ActiveCell.Offset(0, 1)
ActiveCell.Offset(0, 1).ClearContents
Exit Sub
End If '4
Next '-6
ActiveCell.ClearContents

End Sub

You should use recursion to handle the subfolder and their subfolders,
etc. Recursion is a technique in which a function calls itself as
need. In the code below, the DoFolder function calls itself for each
subfolder of the input folder. It continues to call itself as deep as
there are subfolers. See
http://www.cpearson.com/excel/RecursionAndFSO.htm for info about
recursion and see http://www.cpearson.com/excel/FolderTree.aspx for an
add-in that automatically lists folders, subfolders and files.

The code below requires a reference to the Scripting Runtime library.
In VBA, go to the Tools menu, choose References, and then scroll down
to and check "Microsoft Scripting RunTime".


Sub AAA()
Dim FSO As Scripting.FileSystemObject
Dim FF As Scripting.Folder
Dim StartFolder As String
Dim StartCell As Range
Dim Indent As Boolean
Dim ListFiles As Boolean

StartFolder = InputBox("Enter folder path:")
If StartFolder = vbNullString Then
Exit Sub
End If
If Dir(StartFolder, vbDirectory) = vbNullString Then
Exit Sub
End If
On Error Resume Next
Set StartCell = Application.InputBox( _
prompt:="Select start cell.", Type:=8)
If StartCell Is Nothing Then
Exit Sub
End If
On Error GoTo 0

Indent = MsgBox("Indent listing?", vbYesNo) = vbYes
ListFiles = MsgBox("List files?", vbYesNo) = vbYes


Set FSO = New Scripting.FileSystemObject
Set FF = FSO.GetFolder(StartFolder)
DoFolder FF, StartCell, ListFiles, Indent


End Sub

Sub DoFolder(FF As Scripting.Folder, R As Range, ListFiles As Boolean,
Indent As Boolean)

Dim F As Scripting.File
Dim SubF As Scripting.Folder

R.Value = FF.Path
If Indent = True Then
Set R = R(1, 2)
End If
If ListFiles = True Then
For Each F In FF.Files
Set R = R(2, 1)
R.Value = F.Name
Next F
End If
Set R = R(2, 1)
For Each SubF In FF.SubFolders
DoFolder SubF, R, ListFiles, Indent
Next SubF
If Indent Then
Set R = R(1, 0)
End If

End Sub

Cordially,
Chip Pearson
Microsoft Most Valuable Professional
Excel Product Group, 1998 - 2009
Pearson Software Consulting, LLC
www.cpearson.com
(email on web site)



On Mon, 18 May 2009 23:45:01 -0700, Varne
wrote:

Hi Gary

I wrote some codes (given below) for listing sub folders and files in a
Folder. It can be expanded to several levels. I stoped with the first level
sub folder. However it has a few problems like not reading certain sub folder
- If I expand C:\ and then try to expand the sub folders it does not work but
it expands all subfolders in Documents.

Surely there must be a better way. If you know please show me how to do it.

My Work;

Dim StartFolder As String
Dim InputBoxForInteraction As String
Dim InputBoxForStipulatingFolders As String

Sub HeadProcedure()

'Frmatting for New Start
Range("a1:z1000").ClearContents
Columns("a:z").ColumnWidth = 8.43
Cells(1, 1).Select

'Start Folder Expansion
Application.ScreenUpdating = False
InputBoxForStipulatingFolders = Application.InputBox(prompt:="Write Folder
Path leaving out the backslash at the end", Type:=2)
If InputBoxForStipulatingFolders = "" Then '2
Exit Sub
End If '-2
StartFolder = InputBoxForStipulatingFolders & "\"
ActiveCell = StartFolder
Call ListSubFoldersAndFiles(s)
If Cells(2, 2) = "" Then '6
Cells(1, 1).ClearContents
MsgBox "Incorrect Folder Path Description", vbInformation
Cells(1, 1).Select
Columns("a:j").EntireColumn.AutoFit
Exit Sub
End If '-6
Columns("a:j").EntireColumn.AutoFit
Application.ScreenUpdating = True
Application.ScreenUpdating = False
Cells(1, 1).Select
Application.ScreenUpdating = True

'Level 1 Folders Expansion
Application.ScreenUpdating = False
InputBoxForInteraction = Application.InputBox(prompt:="Say 'Yes' if you want
to see the contents of any Level Folders", Type:=2)
If InputBoxForInteraction = "Yes" Then '24
InputBoxForStipulatingFolders = Application.InputBox(prompt:="Write Level 1
Sub Folder Name leaving out the backslash at the end ", Type:=2)
StartFolder = InputBoxForStipulatingFolders & "\"
Call Level1FolderFinder(s)
If Cells(1, 2) = 1 Then '4
Cells(1, 2).ClearContents
MsgBox "Folder Name Incorrect"
Exit Sub
End If '-4
Call ListSubFoldersAndFiles(s)
Call Level1FolderFinder(s)
ActiveCell.Offset(1, 0).Select
If Not ActiveCell.Offset(0, 1) = "" Then '9
Range(Selection, ActiveCell.Offset(1000, 0)).Select
Selection.Cut
Do '2
ActiveCell.Offset(1, 0).Select
Loop Until ActiveCell.Offset(0, 1) = "" '-2
ActiveSheet.Paste
Cells(1, 1).Select
Else
Call RemovingBackSlash(s)
Cells(1, 1).Select
MsgBox "No Contents in " & StartFolder
End If '-9
End If '-24

Columns("a:j").EntireColumn.AutoFit

End Sub

Sub ListSubFoldersAndFiles(s)

Dim ReadFile As String

ReadFile = Dir(StartFolder & "*.*", 16)
ActiveCell.Offset(1, 1).Select
ActiveCell = ReadFile

Do While ReadFile < "" '4
Call RemovingPoint(s)
ReadFile = Dir
ActiveCell = ReadFile
Loop '-4

End Sub

Sub RemovingPoint(s)

Dim LoopLookingForPoint As Integer

For LoopLookingForPoint = Len(ActiveCell) To 1 Step -1 '6
If Not Mid$(ActiveCell, LoopLookingForPoint, 1) = "." Then '-4
Call TaggingSubFolders(s)
ActiveCell.Offset(1, 0).Select
Exit Sub
End If '-4
Next '-6
ActiveCell.ClearContents

End Sub

Sub TaggingSubFolders(s)

Dim LoopLookingForSubFolders

For LoopLookingForFolders = Len(ActiveCell) To 1 Step -1 '4
If Mid$(ActiveCell, LoopLookingForFolders, 1) = "." Then '2
Exit Sub
End If '-2
Next '-4
ActiveCell = ActiveCell & "\"

End Sub

Sub Level1FolderFinder(s)

Cells(1, 2).Select
Do '8
ActiveCell.Offset(1, 0).Select
A = A + 1
If A = 1000 Then '4
Cells(1, 2).Select
ActiveCell = 1
Exit Sub
End If '-4
Loop Until ActiveCell = StartFolder '- 8

End Sub

Sub RemovingBackSlash(s)

Dim LoopLookingForBackSlash As Integer

ActiveCell.Offset(-1, 0).Select
ActiveCell.Offset(0, 1) = ActiveCell
For LoopLookingForBackSlash = Len(ActiveCell.Offset(0, 1)) To 1 Step -1 '6
If Mid$(ActiveCell.Offset(0, 1), LoopLookingForBackSlash, 1) = "\" Then '4
ActiveCell.Offset(0, 1).Characters(LoopLookingForBackSlash).Delete
StartFolder = ActiveCell.Offset(0, 1)
ActiveCell.Offset(0, 1).ClearContents
Exit Sub
End If '4
Next '-6
ActiveCell.ClearContents

End Sub

Hi!

Sorry for responding late. Limited Internet Access. I have taken the codes.
I will reply tomorrow.

Thank You.

M Varnendra

"Chip Pearson" wrote:


You should use recursion to handle the subfolder and their subfolders,
etc. Recursion is a technique in which a function calls itself as
need. In the code below, the DoFolder function calls itself for each
subfolder of the input folder. It continues to call itself as deep as
there are subfolers. See
http://www.cpearson.com/excel/RecursionAndFSO.htm for info about
recursion and see http://www.cpearson.com/excel/FolderTree.aspx for an
add-in that automatically lists folders, subfolders and files.

The code below requires a reference to the Scripting Runtime library.
In VBA, go to the Tools menu, choose References, and then scroll down
to and check "Microsoft Scripting RunTime".


Sub AAA()
Dim FSO As Scripting.FileSystemObject
Dim FF As Scripting.Folder
Dim StartFolder As String
Dim StartCell As Range
Dim Indent As Boolean
Dim ListFiles As Boolean

StartFolder = InputBox("Enter folder path:")
If StartFolder = vbNullString Then
Exit Sub
End If
If Dir(StartFolder, vbDirectory) = vbNullString Then
Exit Sub
End If
On Error Resume Next
Set StartCell = Application.InputBox( _
prompt:="Select start cell.", Type:=8)
If StartCell Is Nothing Then
Exit Sub
End If
On Error GoTo 0

Indent = MsgBox("Indent listing?", vbYesNo) = vbYes
ListFiles = MsgBox("List files?", vbYesNo) = vbYes


Set FSO = New Scripting.FileSystemObject
Set FF = FSO.GetFolder(StartFolder)
DoFolder FF, StartCell, ListFiles, Indent


End Sub

Sub DoFolder(FF As Scripting.Folder, R As Range, ListFiles As Boolean,
Indent As Boolean)

Dim F As Scripting.File
Dim SubF As Scripting.Folder

R.Value = FF.Path
If Indent = True Then
Set R = R(1, 2)
End If
If ListFiles = True Then
For Each F In FF.Files
Set R = R(2, 1)
R.Value = F.Name
Next F
End If
Set R = R(2, 1)
For Each SubF In FF.SubFolders
DoFolder SubF, R, ListFiles, Indent
Next SubF
If Indent Then
Set R = R(1, 0)
End If

End Sub

Cordially,
Chip Pearson
Microsoft Most Valuable Professional
Excel Product Group, 1998 - 2009
Pearson Software Consulting, LLC
www.cpearson.com
(email on web site)



On Mon, 18 May 2009 23:45:01 -0700, Varne
wrote:

Hi Gary

I wrote some codes (given below) for listing sub folders and files in a
Folder. It can be expanded to several levels. I stoped with the first level
sub folder. However it has a few problems like not reading certain sub folder
- If I expand C:\ and then try to expand the sub folders it does not work but
it expands all subfolders in Documents.

Surely there must be a better way. If you know please show me how to do it.

My Work;

Dim StartFolder As String
Dim InputBoxForInteraction As String
Dim InputBoxForStipulatingFolders As String

Sub HeadProcedure()

'Frmatting for New Start
Range("a1:z1000").ClearContents
Columns("a:z").ColumnWidth = 8.43
Cells(1, 1).Select

'Start Folder Expansion
Application.ScreenUpdating = False
InputBoxForStipulatingFolders = Application.InputBox(prompt:="Write Folder
Path leaving out the backslash at the end", Type:=2)
If InputBoxForStipulatingFolders = "" Then '2
Exit Sub
End If '-2
StartFolder = InputBoxForStipulatingFolders & "\"
ActiveCell = StartFolder
Call ListSubFoldersAndFiles(s)
If Cells(2, 2) = "" Then '6
Cells(1, 1).ClearContents
MsgBox "Incorrect Folder Path Description", vbInformation
Cells(1, 1).Select
Columns("a:j").EntireColumn.AutoFit
Exit Sub
End If '-6
Columns("a:j").EntireColumn.AutoFit
Application.ScreenUpdating = True
Application.ScreenUpdating = False
Cells(1, 1).Select
Application.ScreenUpdating = True

'Level 1 Folders Expansion
Application.ScreenUpdating = False
InputBoxForInteraction = Application.InputBox(prompt:="Say 'Yes' if you want
to see the contents of any Level Folders", Type:=2)
If InputBoxForInteraction = "Yes" Then '24
InputBoxForStipulatingFolders = Application.InputBox(prompt:="Write Level 1
Sub Folder Name leaving out the backslash at the end ", Type:=2)
StartFolder = InputBoxForStipulatingFolders & "\"
Call Level1FolderFinder(s)
If Cells(1, 2) = 1 Then '4
Cells(1, 2).ClearContents
MsgBox "Folder Name Incorrect"
Exit Sub
End If '-4
Call ListSubFoldersAndFiles(s)
Call Level1FolderFinder(s)
ActiveCell.Offset(1, 0).Select
If Not ActiveCell.Offset(0, 1) = "" Then '9
Range(Selection, ActiveCell.Offset(1000, 0)).Select
Selection.Cut
Do '2
ActiveCell.Offset(1, 0).Select
Loop Until ActiveCell.Offset(0, 1) = "" '-2
ActiveSheet.Paste
Cells(1, 1).Select
Else
Call RemovingBackSlash(s)
Cells(1, 1).Select
MsgBox "No Contents in " & StartFolder
End If '-9
End If '-24

Columns("a:j").EntireColumn.AutoFit

End Sub

Sub ListSubFoldersAndFiles(s)

Dim ReadFile As String

ReadFile = Dir(StartFolder & "*.*", 16)
ActiveCell.Offset(1, 1).Select
ActiveCell = ReadFile

Do While ReadFile < "" '4
Call RemovingPoint(s)
ReadFile = Dir
ActiveCell = ReadFile
Loop '-4

End Sub

Sub RemovingPoint(s)

Dim LoopLookingForPoint As Integer

For LoopLookingForPoint = Len(ActiveCell) To 1 Step -1 '6
If Not Mid$(ActiveCell, LoopLookingForPoint, 1) = "." Then '-4
Call TaggingSubFolders(s)
ActiveCell.Offset(1, 0).Select
Exit Sub
End If '-4
Next '-6
ActiveCell.ClearContents

End Sub

Sub TaggingSubFolders(s)

Dim LoopLookingForSubFolders

For LoopLookingForFolders = Len(ActiveCell) To 1 Step -1 '4
If Mid$(ActiveCell, LoopLookingForFolders, 1) = "." Then '2
Exit Sub
End If '-2
Next '-4
ActiveCell = ActiveCell & "\"

End Sub

Sub Level1FolderFinder(s)

Cells(1, 2).Select
Do '8
ActiveCell.Offset(1, 0).Select
A = A + 1
If A = 1000 Then '4
Cells(1, 2).Select
ActiveCell = 1
Exit Sub
End If '-4
Loop Until ActiveCell = StartFolder '- 8

End Sub

Sub RemovingBackSlash(s)

Dim LoopLookingForBackSlash As Integer

ActiveCell.Offset(-1, 0).Select
ActiveCell.Offset(0, 1) = ActiveCell
For LoopLookingForBackSlash = Len(ActiveCell.Offset(0, 1)) To 1 Step -1 '6
If Mid$(ActiveCell.Offset(0, 1), LoopLookingForBackSlash, 1) = "\" Then '4
ActiveCell.Offset(0, 1).Characters(LoopLookingForBackSlash).Delete
StartFolder = ActiveCell.Offset(0, 1)
ActiveCell.Offset(0, 1).ClearContents
Exit Sub
End If '4
Next '-6
ActiveCell.ClearContents

End Sub