Macro para interactuar entre Excel y la estructura de un directorio

Objetivo: Generar una macro para Excel que pretenda interpretar la estructura de la carpeta de un proyecto,  listar todos los archivos y carpetas que esta contiene para mostrarnos de manera clara entre las fechas cuáles fueron las actualizaciones y resaltar cualquier información o nombre aplicado a los documentos que no aplique a la estructura de la información propuesta.

Public Sub Actualizar()
Excel.Application.Calculation = xlCalculationManual
Application.DisplayAlerts = False
Application.ScreenUpdating = False
    Range("A2:Z5000").Clear
    Call ListMyFiles(Excel.ThisWorkbook.Path, True, 2)
Excel.Application.Calculation = xlCalculationAutomatic
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

Public Sub ListMyFiles(mySourcePath, IncludeSubfolders, iRow As Long)
Dim iCol As Long: iCol = 1
Dim IRoW_Acum As Long
Dim bcle As Long
Dim bcle2 As Long
Dim Cadena As String
Dim Sig As Long
Dim NCol As Long
Dim Comprueba As Variant
Comprueba = Sheets("Base").Range("A1:C75").Value
Set MyObject = New Scripting.FileSystemObject
Set mySource = MyObject.GetFolder(mySourcePath)
On Error Resume Next
For Each myfile In mySource.Files
    For bcle = Len(myfile.Name) To 1 Step -1
        If Mid(myfile.Name, bcle, 1) = "." Then Exit For
        If Right(myfile.Name, Len(myfile.Name) - Len(Left(myfile.Name, bcle - 1))) = ".tmp" Then GoTo Salta:
        If Right(myfile.Name, Len(myfile.Name) - Len(Left(myfile.Name, bcle - 1))) = ".db" Then GoTo Salta:
    Next
    Cadena = Right(myfile.Path, Len(myfile.Path) - Len(Excel.ActiveWorkbook.Path))
    NCol = 1
    For bcle2 = 1 To Len(Cadena)
        If Mid(Cadena, bcle2, 1) = "\" Then
            If InStr(bcle2 + 1, Cadena, "\") > bcle2 Then
                Sig = InStr(bcle2 + 1, Cadena, "\")
                Dim Segmento As String
                Segmento = Left(Right(Cadena, Len(Cadena) - bcle2), Sig - bcle2)
                Cells(iRow, NCol) = Segmento
                Dim H_Link As String
                Sig = InStr(1, myfile.Path, Segmento)
                H_Link = Left(myfile.Path, Sig - 1) & Segmento
                Cells(iRow, NCol).Hyperlinks.Add anchor:=Cells(iRow, NCol), Address:=H_Link
                Cells(iRow, NCol).Borders.Value = 1
                With Cells(iRow, NCol).Interior
                    .Pattern = xlSolid
                    .PatternColorIndex = xlAutomatic
                    .Color = 10092543
                    .TintAndShade = 0
                    .PatternTintAndShade = 0
                End With
                With Cells(iRow, NCol).Font
                    .Name = "Arial"
                    .Size = 9
                    .Strikethrough = False
                    .Superscript = False
                    .Subscript = False
                    .OutlineFont = False
                    .Shadow = False
                    .Underline = xlUnderlineStyleNone
                    .ColorIndex = xlAutomatic
                    .TintAndShade = 0
                    .ThemeFont = xlThemeFontNone
                End With
                NCol = NCol + 1
            End If
        End If
    Next
    Cells(iRow, NCol) = myfile.Name
    Cells(iRow, NCol).Hyperlinks.Add anchor:=Cells(iRow, NCol), Address:=myfile.Path
    Dim Bcle_Comp As Long
    Dim Color As Long
        Color = 255
    For Bcle_Comp = 1 To UBound(Comprueba)
        If Len(Comprueba(Bcle_Comp, 3)) > 1 And Comprueba(Bcle_Comp, 3) = Left(myfile.Name, Len(Comprueba(Bcle_Comp, 3))) Then
            With Cells(iRow, NCol).Interior
                .Pattern = xlSolid
                .PatternColorIndex = xlAutomatic
                .Color = 5296274
                .TintAndShade = 0
                .PatternTintAndShade = 0
            End With
            NCol = NCol + 1: Cells(iRow, NCol) = Comprueba(Bcle_Comp, 3)
        End If
    Next
    iRow = iRow + 1
Salta:
Next
For Each mySubFolder In mySource.SubFolders
    Call ListMyFiles(mySubFolder.Path, True, iRow)
Next
End Sub

Si te interesa dale al botón G+, comenta, participa...

Y escribime para enviarte el ejemplo!