Jump to content
Fórum Script Brasil
  • 0

Help - Macro para abrir arquivos .XLS de pastas e sub-pastas


Olá amigos,

Estou com problemas para inserir a leitura e abertura de arquivos .XLS em pastas e subpastas. O código abaixo está funcionando apenas para abertura de arquivos .XLS em pastas, porém não funciona em subpastas.

Por favor, se alguém souber o como, ficarei imensamente grato.

Sub open_and_copy()
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False

Dim FSO As Object
Dim pasta_arquivos As String
Dim Planilha As Object
Dim OpenBook As String

Set FSO = CreateObject("Scripting.FileSystemObject")
pasta_arquivos = ThisWorkbook.Sheets("COMPILADOR").Range("H4") 'LOCAL CONTENDO A NOMENCLATURA DO RELATÓRIO'

For Each Planilha In FSO.GetFolder(pasta_arquivos).Files
If InStr(1, Planilha, ".xls") = 0 Then GoTo PROXIMO

Workbooks.Open (Planilha)
    OpenBook = ActiveWorkbook.Name



Link to post
Share on other sites

1 answer to this question

Recommended Posts

  • 0

Boa tarde @glhrdias olha se esse código te atende:

Sub ListAllFilesInAllFolders()
    Dim MyPath As String, MyFolderName As String, MyFileName As String
    Dim i As Integer, F As Boolean
    Dim objShell As Object, objFolder As Object, AllFolders As Object, AllFiles As Object
    Dim MySheet As Worksheet
    On Error Resume Next
    'Select folder
    Set objShell = CreateObject("Shell.Application")
    Set objFolder = objShell.BrowseForFolder(0, "", 0, 0)
    If Not objFolder Is Nothing Then
        MyPath = objFolder.self.Path & "\"
        Exit Sub
       'MyPath = "G:\BackUp\"
    End If
    Set objFolder = Nothing
    Set objShell = Nothing
    'List all folders
    Set AllFolders = CreateObject("Scripting.Dictionary")
    Set AllFiles = CreateObject("Scripting.Dictionary")
    AllFolders.Add (MyPath), ""
    i = 0
    Do While i < AllFolders.Count
        Key = AllFolders.keys
        MyFolderName = Dir(Key(i), vbDirectory)
        Do While MyFolderName <> ""
            If MyFolderName <> "." And MyFolderName <> ".." Then
                If (GetAttr(Key(i) & MyFolderName) And vbDirectory) = vbDirectory Then
                    AllFolders.Add (Key(i) & MyFolderName & "\"), ""
                End If
            End If
            MyFolderName = Dir
        i = i + 1
    'List all files
    For Each Key In AllFolders.keys
        MyFileName = Dir(Key & "*.*")
        'MyFileName = Dir(Key & "*.PDF")    'only PDF files
        Do While MyFileName <> ""
            AllFiles.Add (Key & MyFileName), ""
            MyFileName = Dir
    'List all files in Files sheet
    For Each MySheet In ThisWorkbook.Worksheets
        If MySheet.Name = "Files" Then
            F = True
            Exit For
            F = False
        End If
    If Not F Then Sheets.Add.Name = "Files"
    'Sheets("Files").[A1].Resize(AllFolders.Count, 1) = WorksheetFunction.Transpose(AllFolders.keys)
    Sheets("Files").[A1].Resize(AllFiles.Count, 1) = WorksheetFunction.Transpose(AllFiles.keys)
    Set AllFolders = Nothing
    Set AllFiles = Nothing
End Sub


Link to post
Share on other sites

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.

Answer this question...

×   Pasted as rich text.   Paste as plain text instead

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

  • Forum Statistics

    • Total Topics
    • Total Posts
  • Create New...