0

Estou utilizando esse código para listar as pastas que contem alguns nomes que preciso planilhar.

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 

O que eu gostaria é que toda vez que eu executasse o macro e por exemplo selecionasse a pasta "Julho" ele criasse uma nova planilha dentro da minha atual e listasse os nomes que estão dentro da pasta ( o que esse código já faz) mas gostaria que fosse em formato de planilha e que ele desse o nome da pasta pra planilha recém criada.

inserir a descrição da imagem aqui

Então na tela inicial iria ficar o botão com o macro e o total de processos listados de todos os meses e de cada mês individual (o que eu ainda vou descobrir como fazer) e cada planilha vai ter seus processos listados com o nome do mês que ela pertence.

É possível fazer algo desse tipo ?

2 Respostas 2

0

Pastas

Para criar uma planilha com o nome da Pasta e preencher na coluna A, utilize o seguinte código, em que a explicação está comentada no código:

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

Subpastas e mais dados

Caso deseje também os subdiretórios e outros dados de diretório, utilize o seguinte código:

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
6
  • Gostaria de saber como eu faço pra ele começar a listar a partir da linha A2, gostaria de colocar os títulos pra identificar na primeira linha. Gravei um macro pra ele criar uma planilha com esse dados e deixar bonitinho, mas tem que definir onde começa e onde termina e eu queria que ele criasse a planilha apenas até onde contem texto 16/08/2019 às 20:12
  • @PauloCordeiro No primeiro código, mude de i = 1 para i = 2, já no segundo você precisará ou adicionar o título pelo código na linha 1 ou criar uma condicional if, para verificar se não tiver nada preenchido, pular para a segunda linha. 16/08/2019 às 20:42
  • Muito obrigado cara me ajudou bastante, depois dessas experiencias que tive com alguns programas VBA estou até pensando em cursar algo relacionado á área quando acabar o ensino médio 17/08/2019 às 0:29
  • Desculpe voltar novamente aqui, mas tive que mudar algumas coisas na planilha e agora não consigo mais fazer ela funcionar, eu gostaria de mudar a ideia inicial de apagar a planilha caso ela já exista para limpar toda ela (exceto a celula G1), depois selecionar ela e listar normalmente, consegui alterar a função SheetKiller pra limpar porém não consigo fazer funcionar a partir dai pois sempre aparece um erro diferente, eu imagino que tenha que tirar a parte do Sheet.Add e mudar pra algum código que apenas leve você para a sheet escolhida 26/08/2019 às 0:12
  • Isso tudo pq quando a planilha é apagada estraga uma tabela dinâmica que puxa um dado da linha G1, mesmo ela sendo criada novamente com o mesmo nome não dá certo, então se houver uma maneira de manter isso, o código original pode se manter também 26/08/2019 às 0:23
0

Bom dia!

Segue um exemplo, vai precisar de adaptações. A ideia basicamente é verificar se existe uma planilha com o nome do mês, caso contrário, cria uma nova e renomeia em seguida.

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

Você deve fazer log-in para responder a esta pergunta.

Esta não é a resposta que você está procurando? Pesquise outras perguntas com a tag .