Data da modificação de arquivos de um diretório

2024 - VBA & Macros

Post Recente por ABIMAELABS 7 anos atrás

3 Posts

2 Usuários

0 Reactions

950 Visualizações

RSS

ABIMAELABS

(@abimaelabs)

Posts: 2

New Member

Topic starter

Olá pessoal;

Sou novo aqui no fórum e preciso de uma ajuda de vocês.
Tenho uma macro que me trás o nome dos aquivos de um determinado diretório na coluna A de uma determinada aba da minha planilha
Eu preciso que ele me traga também a data da ultima modificação daquele arquivo na coluna B dessa minha aba.

Outra coisa, terei que adicionar varios diretorios nessa macro.. existe alguma forma mais sintética para essa macro ? Esses diretórios serão alterados todo mês

Public Sub IMPORTAR()
Dim Pasta As String
Dim tpArq As String
Dim Arq As String
Dim i As Long
Set p1 = Sheets("Script")
i = 2
Pasta = Cells(2, 11) 'PASTA DE ORIGEM
Arq = Dir(Pasta & tpArq, vbDirectory)
While Arq <> ""
p1.Range("A" & i) = Arq
i = i + 1
Arq = Dir()
Wend
Pasta = Cells(3, 11) 'PASTA DE ORIGEM 2
Arq = Dir(Pasta & tpArq, vbDirectory)
While Arq <> ""
p1.Range("A" & i) = Arq
i = i + 1
Arq = Dir()

Wend

 Call ATUALIZAR
 
End Sub

Postado : 09/01/2018 8:53 am

Basole

(@basole)

Posts: 487

Reputable Member

Acrescentei uma caixa de dialogo para selecionar as quantidades de pastas desejadas.
Em seguida a macro varre as pastas selecionadas e traz os dados encontrados incluindo a data de alteração.
Veja se atende:

Public Sub IMPORTAR()
    Dim Pasta       As String
    Dim tpArq       As String
    Dim Arq          As String
    Dim i              As Long
    Dim j             As Long
    Dim fs            As Object
    Dim f             As Object
    Dim varDir()  As Variant
    Dim fldr        As FileDialog
    
    Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
seSim:
    With fldr
        .Title = "Selecione uma pasta "
        .AllowMultiSelect = False
        .InitialFileName = ThisWorkbook.Path
        If .Show <> -1 Then GoTo Fim
         ReDim Preserve varDir(i + 1)
        varDir(i) = .SelectedItems(1)
        i = i + 1
    End With
      
    If MsgBox("Deseja selecionar mais uma Pasta?", vbQuestion + vbYesNo, "") = vbYes Then
        GoTo seSim
    Else
                 
        tpArq = "*.xls*"
        
        Set p1 = Sheets("Script")
        j = 2
        
        Set fs = CreateObject("Scripting.FileSystemObject")
        
        For i = LBound(varDir) To UBound(varDir) - 1
            
            Pasta = varDir(i) & VBA.Chr(92) 'PASTA DE ORIGEM
            Arq = Dir$(Pasta & tpArq, vbDirectory)
            
            While Arq <> ""
            Set f = fs.GetFile(Pasta & Arq)
            p1.Range("A" & j) = f.Name
            p1.Range("B" & j) = f.DateLastModified
            Arq = Dir$()
            j = j + 1
            Wend
            
        Next i
        
        p1.Range("A:B").Columns.AutoFit ' ajusta as colunas
        Set fldr = Nothing
        
         Call ATUALIZAR
        
    End If
Fim:
End Sub

Click em se a resposta foi util!