Jump to content
Fórum Script Brasil
  • 0

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


Question

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

PROXIMO:
Next

 

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 & "\"
    Else
        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
        Loop
        i = i + 1
    Loop
     
    '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
        Loop
    Next
     
    '************************
    'List all files in Files sheet
     
    For Each MySheet In ThisWorkbook.Worksheets
        If MySheet.Name = "Files" Then
            Sheets("Files").Cells.Delete
            F = True
            Exit For
        Else
            F = False
        End If
    Next
    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.

Guest
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
      149151
    • Total Posts
      645419
×
×
  • Create New...