Objetos Filelist-and-SubFolder List
Option Explicit
Sub NEWOFNEW()
Rem create today 14/09/2010 for Tinno
Rem in Excel of course
Dim FSO As New FileSystemObject
Dim T As Object, ShApp As Object
Dim Dto As String
Dim f, A
Dim i As Long, ii As Long
Dim r As Long, NF As Long
Workbooks.Add
Range("A1").Select
Set ShApp = CreateObject("Shell.Application")
On Error Resume Next
With ShApp
Dto = .Browseforfolder(0, "Directorio a Listar", 0, "").Items.Item.Path
End With
On Error GoTo 0
If IsEmpty(Dto) = True Or Dto = "" Then GoTo Sies
With Range("A1")
.Value = Dto
.Font.ColorIndex = 3
.Offset(1, 0).Select
End With
hom:
Set T = FSO.GetFolder(Dto).SubFolders
For Each f In T
With ActiveCell
.Value = Dto & "\" & f.Name
.Font.ColorIndex = 3
.Offset(1, 0).Select
End With
Next
r = [A65536].End(xlUp).Row
A = Dir(Dto & "\", vbArchive)
Do
With ActiveCell
If A = "." Or A = ".." Or A = "" Then
Else
.Value = Dto & "\" & A
.Offset(1, 0).Select
End If
End With
On Error Resume Next
A = Dir()
On Error GoTo 0
Loop Until A = ""
Set T = Nothing
If r = 1 Then GoTo Sies
For i = 1 To r
Dto = Cells(i, 1).Value
Set T = FSO.GetFolder(Dto).SubFolders
For Each f In T
With ActiveCell
.Value = Dto & "\" & f.Name
.Font.ColorIndex = 3
.Offset(1, 0).Select
End With
Next
A = Dir(Dto & "\", vbArchive)
Do
With ActiveCell
If A = "." Or A = ".." Or A = "" Then
Else
.Value = Dto & "\" & A
.Offset(1, 0).Select
End If
End With
On Error Resume Next
A = Dir()
On Error GoTo 0
Loop Until A = ""
Next
Set T = Nothing
ii = r + 1
Cells(ii, 1).Select
Do
ree:
Cells(ii, 1).Select
If ActiveCell.Row = [A65536].End(xlUp).Row Or ActiveCell.Row = 65535 Then GoTo ESEL
If CBool(ActiveCell.Font.ColorIndex = 3) = True Then
Dto = Cells(ii, 1).Value
Set T = FSO.GetFolder(Dto).SubFolders
For Each f In T
NF = [A65536].End(xlUp).Row + 1
With Range("A" & NF)
.Select
.Value = Dto & "\" & f.Name
.Font.ColorIndex = 3
End With
Next
A = Dir(Dto & "\", vbArchive)
Do
NF = [A65536].End(xlUp).Row + 1
With Range("A" & NF)
If A = "." Or A = ".." Or A = "" Then
Else
.Select
.Value = Dto & "\" & A
End If
End With
On Error Resume Next
A = Dir()
On Error GoTo 0
Loop Until A = ""
Set T = Nothing
ii = ii + 1
GoTo ree
Else
ii = ii + 1
GoTo ree
End If
ESEL:
Loop Until CBool(ActiveCell.Font.ColorIndex = 3) = False Or ActiveCell.Row = [A65536].End(xlUp).Row
Range("A1").Select
Range(Selection, Selection.End(xlUp)).Select
Selection.Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlGuess ', _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
Sies:
MsgBox "ALL READY"
End Sub