Create a spreadsheet with folder names listed from a directory in excel

Question

I’m using this code to list the folders that contain some names I need to spreadsheet.

Option Explicit

Sub CreateList()
    Application.ScreenUpdating = False
    Workbooks.Add    ' create a new workbook for the folder list
    ' add headers
    With Cells(1, 1)
        .Value = "Folder contents:"
        .Font.Bold = True
        .Font.Size = 12
    End With
    Cells(3, 1).Value = "Folder Path:"
    Cells(3, 2).Value = "Folder Name:"
    Cells(3, 3).Value = "Size:"
    Cells(3, 4).Value = "Subfolders:"
    Cells(3, 5).Value = "Files:"
    Cells(3, 6).Value = "Short Name:"
    Cells(3, 7).Value = "Short Path:"
    Range("A3:G3").Font.Bold = True
    ListFolders BrowseFolder, True
    Application.ScreenUpdating = True
End Sub

Sub ListFolders(SourceFolderName As String, IncludeSubfolders As Boolean)
    ' lists information about the folders in SourceFolder
    Dim FSO    As Scripting.FileSystemObject
    Dim SourceFolder As Scripting.Folder, SubFolder As Scripting.Folder
    Dim r      As Long
    Set FSO = New Scripting.FileSystemObject
    Set SourceFolder = FSO.GetFolder(SourceFolderName)
    ' display folder properties
    r = Cells(Rows.Count, 1).End(xlUp).Row + 1
    Cells(r, 1).Value = SourceFolder.Path
    Cells(r, 2).Value = SourceFolder.Name
    Cells(r, 3).Value = SourceFolder.Size
    Cells(r, 4).Value = SourceFolder.SubFolders.Count
    Cells(r, 5).Value = SourceFolder.Files.Count
    Cells(r, 6).Value = SourceFolder.ShortName
    Cells(r, 7).Value = SourceFolder.ShortPath
    If IncludeSubfolders Then
        For Each SubFolder In SourceFolder.SubFolders
            ListFolders SubFolder.Path, True
        Next SubFolder
        Set SubFolder = Nothing
    End If
    Columns("A:G").AutoFit
    Set SourceFolder = Nothing
    Set FSO = Nothing
    ActiveWorkbook.Saved = True

End Sub 

What I would like is that every time I run the macro and for example select the folder "July" he create a new sheet within my current and list the names that are inside the folder ( what this code already does) but I would like it to be in spreadsheet format and to give the folder name to the newly created spreadsheet.

Then on the home screen would be the button with the macro and the total of processes listed of every month and each individual month (which I will still figure out how to do) and each spreadsheet will have its processes listed with the name of the month it belongs to.

It’s possible to do something like this ?

Answer 1

Folders

To create a sheet with the Folder name and fill in column A, use the following code, where the explanation is commented in the code:

Option Explicit
Sub Listar_Pastas()
    ''''''''''''''''''''
    '====  Pastas  ===='
    ''''''''''''''''''''
    Application.Calculation = xlCalculationManual
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Dim xPath As String, xDir As String
    Dim xWs_pastas As Worksheet
    Dim fso As Object
    Dim fso_FOLDER As Object
    Dim fso_folders As Object
    Dim i As Long

    Set fso = CreateObject("Scripting.FileSystemObject")

    'Janela para escolher a pasta do diretório desejado
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Escolha a pasta"
        .Show
    End With
    On Error Resume Next
    xPath = Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1) & "\"

    If xPath = "" Then
        GoTo CleanExit                           'Se o caminho da pasta não existir
    End If
    'Define novo Objeto FSO GetFolder
    Set fso_FOLDER = fso.GetFolder(xPath)
    xDir = fso_FOLDER.Name
    'Apaga se houver planilha com mesmo nome existente
    CriarPlanilha (xDir)
    'Define nova planilha da pasta
    Set xWs_pastas = ThisWorkbook.Sheets(xDir)

    'https://stackoverflow.com/a/31428399/7690982
    'Encontra todos os Arquivos
    i = 1
    If fso_FOLDER.subFolders.Count > 0 Then
        'Loop em cada pasta do diretório escolhido
        For Each fso_folders In fso_FOLDER.subFolders
            With xWs_pastas
                'Preenche a coluna A com a lista de arquivos
                    .Cells(i, "A") = fso_folders.Name
            End With
            i = i + 1
        Next fso_folders
    Else
        MsgBox "Nenhuma pasta encontrada em " & xPath
        GoTo CleanExit
    End If

    'Sair do código
CleanExit:

    Set fso = Nothing
    Set fso_FOLDER = Nothing
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    If Err.Number <> 0 Then MsgBox "Ocorreu um erro em: " & Err.Number & " " & Err.Description
End Sub

Public Function CriarPlanilha(Name As String)
    Dim s As Worksheet, t As String
    Dim i As Long, k As Long
    Dim t_exists As Boolean
    k = ThisWorkbook.Sheets.Count
    t_exists = False
    'Verifica em todas as planilhas se o nome já existe
    For i = k To 1 Step -1
        t = ThisWorkbook.Sheets(i).Name
        If t = Name Then
            'Se existir, limpa o conteúdo
            t_exists = True
            Application.DisplayAlerts = False
            ThisWorkbook.Sheets(i).UsedRange.ClearContents
            Application.DisplayAlerts = True
        End If
    Next i
    'Se não existir, cria nova planilha
    If t_exists = False Then
            ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(k)).Name = Name
    End If
End Function

Subfolders and more data

If you also want the subdirectories and other directory data, use the following code:

Option Explicit
Sub Listar_Subdir()
    ''''''''''''''''''''
    '====  Subdir  ===='
    ''''''''''''''''''''
    Application.Calculation = xlCalculationManual
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Dim xDir As String, xDirName As String
    Dim xWs As Worksheet
    Dim ncell As Long
    Dim vaArray     As Variant
    Dim i As Long, j As Long
    Dim folder As Object, fso As Object

    'https://www.extendoffice.com/documents/excel/2994-excel-list-all-files-in-folder-and-subfolders.html
    'Updateby20150706
    Set folder = Application.FileDialog(msoFileDialogFolderPicker)
    Set fso = CreateObject("Scripting.FileSystemObject")
    'Escolher a pasta desejada
    With folder
        .Title = "Escolha a pasta"
    End With
    If folder.Show <> -1 Then GoTo CleanExit
    On Error Resume Next
    xDir = folder.SelectedItems(1) & "\"
    xDirName = fso.GetFolder(xDir).Name
    'Cria a planilha com o nome do Diretório
    SheetKiller (xDirName)
    ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(Sheets.Count)).Name = xDirName
    Set xWs = ThisWorkbook.Sheets(xDirName)
    'Cria a Lista de Subdiretórios na planilha xWs
    ListFilesInFolder xDir, True, xWs

    'Sair do código
CleanExit:
    Set fso = Nothing
    Set folder = Nothing
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    If Err.Number <> 0 Then MsgBox "Ocorreu um erro em: " & Err.Number & " " & Err.Description
End Sub

Public Sub ListFilesInFolder(ByVal xFolderName As String, ByVal xIsSubfolders As Boolean, xWs As Worksheet)
    Dim xFileSystemObject As Object
    Dim xFolder As Object
    Dim xSubFolder As Object
    Dim xFolderChild As Object
    Dim rowIndex As Long
    Set xFileSystemObject = CreateObject("Scripting.FileSystemObject")
    Set xFolder = xFileSystemObject.GetFolder(xFolderName)
    rowIndex = xWs.Range("A" & xWs.Rows.Count).End(xlUp).Row + 1
    For Each xSubFolder In xFolder.SubFolders
        With xWs
            .Cells(rowIndex, 1) = xSubFolder.Path
            .Cells(rowIndex, 2) = xSubFolder.Name
            .Cells(rowIndex, 3) = xSubFolder.Size
            .Cells(rowIndex, 4) = xSubFolder.ShortName
            .Cells(rowIndex, 5) = xSubFolder.ShortPath
            .Cells(rowIndex, 6) = xSubFolder.DateCreated
            .Cells(rowIndex, 7) = xSubFolder.DateLastAccessed
            .Cells(rowIndex, 8) = xSubFolder.DateLastModified
        End With
        rowIndex = rowIndex + 1
    Next xSubFolder
    If xIsSubfolders Then
        For Each xFolderChild In xFolder.SubFolders
            ListFilesInFolder xFolderChild.Path, True, xWs
        Next xFolderChild
    End If
    Set xSubFolder = Nothing
    Set xFolder = Nothing
    Set xFileSystemObject = Nothing
End Sub

Public Function SheetKiller(Name As String)
    Dim s As Worksheet, t As String
    Dim i As Long, k As Long
    k = ThisWorkbook.Sheets.Count

    For i = k To 1 Step -1
        t = ThisWorkbook.Sheets(i).Name
        If t = Name Then
            Application.DisplayAlerts = False
            ThisWorkbook.Sheets(i).Delete
            Application.DisplayAlerts = True
        End If
    Next i
End Function

Answer 2

Good morning!

Follow an example, you’ll need adjustments. The idea is basically to check if there is a spreadsheet with the name of the month, otherwise create a new and rename then.

Sub ListFolders(SourceFolderName As String, IncludeSubfolders As Boolean)
    ' lists information about the folders in SourceFolder
    Dim FSO    As Scripting.FileSystemObject
    Dim SourceFolder As Scripting.Folder, SubFolder As Scripting.Folder
    Dim r      As Long
    Set FSO = New Scripting.FileSystemObject
    Set SourceFolder = FSO.GetFolder(SourceFolderName)

    '========================================================================
    'Verifica se a plan existe, caso contrário, cria uma nova com o nome atual
    Dim qtd As Single
    Dim existe As Boolean

    For qtd = 1 To ActiveWorkbook.Sheets.Count
        If UCase(Sheets(qtd).Name) = "JANEIRO" Then
            existe = True
            Exit For
        End If

        If UCase(Sheets(qtd).Name) = "FEVEREIRO" Then
            existe = True
            Exit For
        End If

        'completar os demais meses

    Next

    'Cria a pasta caso não exista
    If Not existe Then
        Sheets.Add
        ActiveSheet.Name = SourceFolderName
    End If


    '========================================================================

    ' display folder properties
    r = Cells(Rows.Count, 1).End(xlUp).Row + 1
    Cells(r, 1).Value = SourceFolder.Path
    Cells(r, 2).Value = SourceFolder.Name
    Cells(r, 3).Value = SourceFolder.Size
    Cells(r, 4).Value = SourceFolder.SubFolders.Count
    Cells(r, 5).Value = SourceFolder.Files.Count
    Cells(r, 6).Value = SourceFolder.ShortName
    Cells(r, 7).Value = SourceFolder.ShortPath
    If IncludeSubfolders Then
        For Each SubFolder In SourceFolder.SubFolders
            ListFolders SubFolder.Path, True
        Next SubFolder
        Set SubFolder = Nothing
    End If
    Columns("A:G").AutoFit
    Set SourceFolder = Nothing
    Set FSO = Nothing
    ActiveWorkbook.Saved = True

End Sub