Visual Basic Achar Access e trazer nome do arquivo e local onde está salvo

RODRIGO ZAMENGO · 28 de agosto de 2019

Bom dia,

Estou precisando encontrar todos os access (.accdb) em um diretório e retornar com o nome dos arquivos na coluna A de um excel e o local onde o arquivo está salvo na coluna B.

Eu achei uma macro (no site https://www.exceldoseujeito.com.br/macro-para-localizar-arquivos-no-computador-e-listar-na-planilha/) que encontra .mp3 e traz o nome mas não consegui adaptar

Sub Listar_arquivos_mp3()
Dim i As Long
Dim sh As Worksheet
Dim iSomaMb As Double
Dim sPasta As Variant
Dim iLinha As Long
    Set sh = ThisWorkbook.ActiveSheet
    'Exibe a caixa para escolha da pasta onde será feita a pesquisa
    sPasta = GetPasta
    If sPasta = "" Then
        Exit Sub        'Cancela pesquisa
    End If
    'Apaga o conteúdo
    sh.Range("B:C").EntireColumn.ClearContents
    'Escreve o cabeçalho
    sh.Cells(4, 2).Value = "Música"
    sh.Cells(4, 3).Value = "Tamanho (Mb)"
    'Define a linha inicial da listagem
    iLinha = 5
    Application.StatusBar = "Aguarde... Pesquisando ... "
    'Usa o objeto de pesquisa
    With Application.FileSearch
        .LookIn = sPasta                        'Define a pasta onde será pesquisado
        .Filename = "*.mp3"                     'Define o termo da pesquisa
        .SearchSubFolders = True                'Informa se será feita a pesquisa nas subpastas
        .Execute                                'Executa a pesquisa  Ohhhhh!!!!
        'Percorre os itens encontrados e escreve na planilha
        For i = 1 To .FoundFiles.Count
            sh.Cells(iLinha, 2).Value = .FoundFiles(i)
            sh.Cells(iLinha, 3).Value = CDbl(Format((FileLen(.FoundFiles(i)) / 1048576), "0.00"))
            iSomaMb = iSomaMb + sh.Cells(iLinha, 3).Value
            iLinha = iLinha + 1
            Application.StatusBar = "Preenchendo lista ... " & Format(i / .FoundFiles.Count, "0%")
        Next i
        sh.Cells(1, 2).Value = "Músicas em " & sPasta
        sh.Cells(2, 2).Value = "Total de Músicas: " & .FoundFiles.Count
        sh.Cells(3, 2).Value = "Espaço Utilizado: " & Format(iSomaMb, "0.00") & " MB"
    End With
    sh.Range("A1").Select
    Application.StatusBar = False
End Sub

Tks

Basole · 28 de agosto de 2019

Veja se este exemplo lhe atende:

  Sub Listar_Accdb_Local()
    Dim objFSO As Object
    Dim objFolder As Object
    Dim objFile As Object
    Dim i As Integer
    Dim pasta As FileDialog
    Dim sItem As String
    
    Set pasta = Application.FileDialog(msoFileDialogFolderPicker)
    With pasta
        .Title = "Selecione uma Pasta"
        .AllowMultiSelect = False
          If .Show <> -1 Then
          sItem = ""
          If sItem = "" Then Exit Sub
        Else
          sItem = .SelectedItems(1)
       End If
    End With
    
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    
    Set objFolder = objFSO.GetFolder(sItem)
    i = 1
    'limpa o intervalo
    With ActiveSheet
    .Range("A:B").EntireColumn.ClearContents
    'Escreve o cabeçalho
    .Cells(1, 1).Value = "Nome Arquivo"
    .Cells(1, 2).Value = "Local do Arquivo"
    
    For Each objFile In objFolder.Files
    
    If objFile.Name Like "*.*cdb" Then
    'nome arquivo
    .Cells(i + 1, 1) = objFile.Name
    'caminho arquivo
    .Cells(i + 1, 2) = VBA.Left(objFile.Path, Vba.InStrRev(objFile.Path, "\"))
    i = i + 1
    End If
    
    Next objFile
    
    End With
    End Sub