Macro - Retirar nomes dos arquivos dentro de uma pasta

lfsat52 · 7 de janeiro de 2012

Hello amigos!

preciso de uma força,

Preciso retirar o nome dos arquivos contidos dentro de uma determinada pasta

para facilitar no meu dia-a-dia

algum pode me ajudar?

Gostaria de uma macro em que eu apontando a pasta, ela me retornaria o nome de todos os arquivos contidos nas pastas nas células do excel sem formatação mesmo

valeu

7 de janeiro de 2012

1.o código abaixo lista os arquivos de uma pasta e suas sub pastas na Plan1, colocando em 'A' o nome da pasta/sub pasta e em 'B' o nome e a extensão de cada arquivo

2. cole o código em um módulo comum

3. após disparado, o código vai abrir uma caixa de diálogo para que seja selecionada a pasta a pesquisar

4. em seguida abre outra caixa para a escolha do nome e do tipo de arquivo a pesquisar (para listar todos os arquivos da pasta insira curingas nessa caixa *.*, ou para listar arquivos XL 2003 coloque *.xls, ...)

5. em seguida abre outra caixa que permite incluir na pesquisa as sub pastas da pasta escolhida

Sub ListaArquivos()
    Dim myDir As String, temp(), myList, myExtension As String
    Dim SearchSubFolders As Boolean, Rtn As Integer, msg As String
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show Then
            myDir = .SelectedItems(1)
        End If
    End With
    msg = "nome e extensão do arquivo procurado;" & vbLf & "os curingas abaixo podem ser utilizados" & _
     vbLf & "              * # ?"
    myExtension = Application.InputBox(msg)
    If (myExtension = "False") + (myExtension = "") Then Exit Sub
    Rtn = MsgBox("incluir sub pastas na pesquisa ?", vbYesNo)
    SearchSubFolders = Rtn = 6
    myList = SearchFiles(myDir, myExtension, 0, temp(), SearchSubFolders)
    If Not IsError(myList) Then
        Sheets(1).Cells(1).Resize(UBound(myList, 2), 2).Value = _
        Application.Transpose(myList)
    Else
        MsgBox "não encontrado"
    End If
End Sub


Private Function SearchFiles(myDir As String _
    , myFileName As String, n As Long, myList() _
    , Optional SearchSub As Boolean = False) As Variant
    Dim fso As Object, myFolder As Object, myFile As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    For Each myFile In fso.getfolder(myDir).Files
        Select Case myFile.Attributes
        Case 2, 4, 6, 34
        Case Else
            If (Not myFile.Name Like "~$*") _
            * (myFile.Path & "\" & myFile.Name <> ThisWorkbook.FullName) _
            * (UCase(myFile.Name) Like UCase(myFileName)) Then
                n = n + 1
                ReDim Preserve myList(1 To 2, 1 To n)
                myList(1, n) = myDir
                myList(2, n) = myFile.Name
            End If
        End Select
    Next
    If SearchSub Then
        For Each myFolder In fso.getfolder(myDir).subfolders
            SearchFiles = SearchFiles(myFolder.Path, myFileName, _
            n, myList, SearchSub)
        Next
    End If
    SearchFiles = IIf(n > 0, myList, CVErr(xlErrRef))
End Function