locked
Trabalhar com varias pastas de trabalho RRS feed

  • Pergunta

  • Bom dia

     

    Seguinte pessoal, preciso de uma ajudona de vocês

    eu tenho que fazer uma macro que possa consolidar dados de varias pastas de trabalho com o mesmo padrão de nome,ex: Questionário1,Questionario2,... e por ae vai.

    Só que tenho um problema: O número de pastas de trabalho pode variar ou seja eu posso rodar a macro com duas pastas de trabalho ou posso rodar até com 50 pastas de trabalho ou ate mais.

     

    Alguem sabe como posso fazer isso?

    E se não for pedir demais podem me detalhar por meio de comentários, pois eu preciso aprender isso para apresentar pro chefe depois, hehe!

    Outra pregunta: Como faço referencia a estas pastas de trabalho?

    ex:Referencias a planilha:"Sheets("1").Select"

     

    Obrigado desde já

     

    Abraço e Bom Fim de Semana

    sexta-feira, 16 de maio de 2008 19:52

Respostas

  • Olá, meu caro.

    Suponho que as pastas de trabalho estejam salvas num mesmo diretório.

    O código abaixo abre todas as pastas do diretório C:\TESTE cujo nome se inicia com "Quest" (estabelecido por meio da variável Chave) e em cada uma dela auto-ajusta as colunas A e B das Worksheets(1). Os comentários já estão inclusos, mas se ficar alguma dúvida, pode perguntar à vontade.

     

    Code Snippet

    Sub AbrirArquivosemDiretório()
    '****************************************************************

    'MACRO PARA ABERTURA DE CORREÇÃO DE TODOS OS ARQUIVOS DE UM

    'DIRETÓRIO QUE ATENDAM A UMA CONDIÇÃO DE NOME

    'Criada por; Adilson Soledade

    'Criada em: 16/05/2008

    '****************************************************************

     

    Dim Pasta As String, Arquivo As String

     

    Pasta = "C:\TESTE\"

    Chave = "Quest"

    'O comando Dir exibe o nome dos arquivo do diretório Pasta

    Arquivo = Dir(Pasta & "*.xl?", vbNormal)
    'Comando para abrir o arquivo com base do nome da Pasta + Arquivo

    Workbooks.Open (Pasta & Arquivo)
    'Testa se o nome do arquivo se inicia com Chave

    If Left(Arquivo, Len(Chave)) = Chave Then

      'Acessa Worksheets(1) e auto ajusta as colunas A e B

      ActiveWorkbook.Worksheets(1).Columns("A:B").EntireColumn.AutoFit

       'Fecha o arquivo modificado e salva as alterações

           ActiveWorkbook.Close (True)

       'Loop para abertura dos demais arquivos do diretório com os mesmos comandos acima
      Do
      Arquivo = Dir()
        If Arquivo <> "" Then
          Workbooks.Open (Pasta & Arquivo)
          ActiveWorkbook.Worksheets(1).Columns("A:B").EntireColumn.AutoFit
          ActiveWorkbook.Close (True)
        End If

      Loop While Arquivo <> ""

     

    End If

     

    End Sub

     

     

     

     

    [ ]s

    sexta-feira, 16 de maio de 2008 20:52
  • Adilson

     

    Consegui com algumas alterações, muito obrigado novamente pela sua ajuda e como sempre digo se precisar de mim e estiver a meu alcance estou a disposição!

     

    Segue a macro:

     

    Code Snippet

    Option Explicit
    'API declarations
    Declare Function SHGetPathFromIDList Lib "shell32.dll" _
      Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) _
      As Long

    Declare Function SHBrowseForFolder Lib "shell32.dll" _
    Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long

    Public Type BROWSEINFO
        hOwner As Long
        pidlRoot As Long
        pszDisplayName As String
        lpszTitle As String
        ulFlags As Long
        lpfn As Long
        lParam As Long
        iImage As Long
    End Type

    Dim FilePath

     

     

     

    Sub AbrirArquivosemDiretório()
    '****************************************************************

    'MACRO PARA ABERTURA DE CORREÇÃO DE TODOS OS ARQUIVOS DE UM

    'DIRETÓRIO QUE ATENDAM A UMA CONDIÇÃO DE NOME

     

    'Criada por: Adilson Soledade

     

    'Criada em: 16/05/2008

    '****************************************************************

     

    Dim Pasta As String, Arquivo As String, Chave


    Call FileInfo
    Pasta = FilePath & "\"
    Chave = "Quest"

    'O comando Dir exibe o nome dos arquivo do diretório Pasta

    Arquivo = Dir(Pasta & "*.xl?", vbNormal)
    'Comando para abrir o arquivo com base do nome da Pasta + Arquivo

    Workbooks.Open (Pasta & Arquivo)
    'Testa se o nome do arquivo se inicia com Chave

    If Left(Arquivo, Len(Chave)) = Chave Then

      'Acessa Worksheets(1) e auto ajusta as colunas A e B

      ActiveWorkbook.Worksheets(1).Columns("A:B").EntireColumn.AutoFit

       'Fecha o arquivo modificado e salva as alterações

           ActiveWorkbook.Close (True)

       'Loop para abertura dos demais arquivos do diretório com os mesmos comandos acima
      Do
      Arquivo = Dir()
        If Arquivo <> "" Then
          Workbooks.Open (Pasta & Arquivo)
          ActiveWorkbook.Worksheets(1).Columns("A:B").EntireColumn.AutoFit
          ActiveWorkbook.Close (True)
        End If

      Loop While Arquivo <> ""

     

    End If

     

    End Sub

     

    Sub FileInfo()
        Dim c As Long, r As Long, i As Long
        Dim FileName As Object 'FolderItem2
        Dim objShell As Object 'IShellDispatch4
        Dim objFolder As Object 'Folder3
       
    '   Create the object
        Set objShell = CreateObject("Shell.Application")
       
    '   Prompt for the folder
        Set objFolder = objShell.Namespace(GetDirectory)

        MsgBox FilePath

    End Sub

     

     

    Function GetDirectory(Optional Msg) As String
    '   Returns the directory specified by the user
        Dim bInfo As BROWSEINFO
        Dim path As String
        Dim r As Long, x As Long, pos As Integer
        Dim FileName
     

    '   Title in the dialog
        If IsMissing(Msg) Then
            bInfo.lpszTitle = "Selecione o diretório aonde estão as pastas de trabalho"
        Else
            bInfo.lpszTitle = Msg
        End If
       
    '   Type of directory to return
        bInfo.ulFlags = &H1

    '   Display the dialog
        x = SHBrowseForFolder(bInfo)
       
    '   Parse the result
        path = Space$(512)
        r = SHGetPathFromIDList(ByVal x, ByVal path)
        If r Then
            pos = InStr(path, Chr$(0))
            GetDirectory = Left(path, pos - 1)
        Else
            GetDirectory = ""
        End If
        FilePath = GetDirectory
    End Function

     

     

    Muito Obrigado novamente se tiver sugestões por favor me informe.

    e muito obrigado a você tambem EvangelistaLion pela sua ajuda e atenção se precisar de ajuda e estiver a meu alcance peça e considere feito, muito obrigado.

     

    Abraços

    muito obrigado!

    segunda-feira, 19 de maio de 2008 13:36

Todas as Respostas

  • Olá, meu caro.

    Suponho que as pastas de trabalho estejam salvas num mesmo diretório.

    O código abaixo abre todas as pastas do diretório C:\TESTE cujo nome se inicia com "Quest" (estabelecido por meio da variável Chave) e em cada uma dela auto-ajusta as colunas A e B das Worksheets(1). Os comentários já estão inclusos, mas se ficar alguma dúvida, pode perguntar à vontade.

     

    Code Snippet

    Sub AbrirArquivosemDiretório()
    '****************************************************************

    'MACRO PARA ABERTURA DE CORREÇÃO DE TODOS OS ARQUIVOS DE UM

    'DIRETÓRIO QUE ATENDAM A UMA CONDIÇÃO DE NOME

    'Criada por; Adilson Soledade

    'Criada em: 16/05/2008

    '****************************************************************

     

    Dim Pasta As String, Arquivo As String

     

    Pasta = "C:\TESTE\"

    Chave = "Quest"

    'O comando Dir exibe o nome dos arquivo do diretório Pasta

    Arquivo = Dir(Pasta & "*.xl?", vbNormal)
    'Comando para abrir o arquivo com base do nome da Pasta + Arquivo

    Workbooks.Open (Pasta & Arquivo)
    'Testa se o nome do arquivo se inicia com Chave

    If Left(Arquivo, Len(Chave)) = Chave Then

      'Acessa Worksheets(1) e auto ajusta as colunas A e B

      ActiveWorkbook.Worksheets(1).Columns("A:B").EntireColumn.AutoFit

       'Fecha o arquivo modificado e salva as alterações

           ActiveWorkbook.Close (True)

       'Loop para abertura dos demais arquivos do diretório com os mesmos comandos acima
      Do
      Arquivo = Dir()
        If Arquivo <> "" Then
          Workbooks.Open (Pasta & Arquivo)
          ActiveWorkbook.Worksheets(1).Columns("A:B").EntireColumn.AutoFit
          ActiveWorkbook.Close (True)
        End If

      Loop While Arquivo <> ""

     

    End If

     

    End Sub

     

     

     

     

    [ ]s

    sexta-feira, 16 de maio de 2008 20:52
  • Pelo que entendi você pode fazer assim...

    Este código conta quantas pasta de trabalhos você possui no seu diretório.....

    Code Snippet

    Dim n As Integer
    Sub ListaArquivos()
    Set fs = Application.FileSearch
    With fs
        .LookIn = "C:\Documents and Settings\Adm\Desktop\PASTA"
        .Filename = "*.xls"
        .Execute
        If .FoundFiles(1) > 0 Then
           n = .FoundFiles.Count
        Else
            MsgBox "Não existem documentos nesta pasta."
        End If
    End With

    End Sub

     

     

     

    Este código executa sua macro na quantidade de pastas que você possuir ..

    Code Snippet

    Sub Rotina()
    n = 0
    ListaArquivos
    For I = 1 To n

        'Sua Macro

    Next
    End Sub

     

     

     

    Para fazer referência a uma pasta de trabalho..

    Code Snippet

    Workbooks("Pasta1").Select

     

     

    Até..
    sexta-feira, 16 de maio de 2008 21:07
  • Bom Dia

     

    muito obrigado Adilson pela dica a macro serviu direitinho muito obrigado mesmo, mas temos um problema a mais:Não sou eu que vou usar essa macro para consolidar esses dados,você sabe algum jeito de eu colocar num Form uma arvore onde o usuario procura o diretorio que ficará na variavel "Pasta"?Por Exemplo:

     

    Sabe aquela arvore do Windows Explorer, você escolheria o diretorio numa árvore como aquela e a macro pesquisaria naquele diretório.Entendi?

     

    Muito Obrigado pela sua ajuda!

    Abraço

    segunda-feira, 19 de maio de 2008 12:21
  • Sugiro que vc use os comandos do código abaixo, pois nõa haverá encessidade de construir o userform, bastando usar a caixa de diálogo do próprio windows. O resultado (uma string) fica armazenado na variável Diretório.

    Code Snippet
    Sub SelecionarDiretório()
    Dim Diretório
    With Application.FileDialog(msoFileDialogFolderPicker)
    .InitialFileName = "C:\"
    .Title = "Selecione o folder que contém os arquivos"
    .Show
        If .SelectedItems.Count = 0 Then
            MsgBox "Cancelado"
        Else
            Diretório = .SelectedItems(1)
        End If
    End With
    End Sub

     

     

    [ ]s

     

    segunda-feira, 19 de maio de 2008 13:02
  • Aprece o seguinte erro:

    Variável Não definida e seleciona a parte em azul da linha abaixo:

     

    With Application.FileDialog(msoFileDialogFolderPicker)

     

    eu pesquisei no forum e encontrei um post seu com uma macro semelhante e achei o resultado muito interessante mas ao usar a macro a variavel do diretorio ficou  por exemplo assim:"C:\Documents and Settings\bc611373\Meus documentos\Teste" e por não ter a barra no final ,ou seja, "C:\Documents and Settings\bc611373\Meus documentos\Teste\" ele não consegue acessar o diretório.Qual você acha mais facil corrigir?Estou seguindo suas sugestões.Segue a Macro completa que estou usando junto com seus exemplos:

     

    Code Snippet

    Option Explicit
    'API declarations
    Declare Function SHGetPathFromIDList Lib "shell32.dll" _
      Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) _
      As Long

    Declare Function SHBrowseForFolder Lib "shell32.dll" _
    Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long

    Public Type BROWSEINFO
        hOwner As Long
        pidlRoot As Long
        pszDisplayName As String
        lpszTitle As String
        ulFlags As Long
        lpfn As Long
        lParam As Long
        iImage As Long
    End Type

    Dim FilePath

    Sub FileInfo()
        Dim c As Long, r As Long, i As Long
        Dim FileName As Object 'FolderItem2
        Dim objShell As Object 'IShellDispatch4
        Dim objFolder As Object 'Folder3
       
    '   Create the object
        Set objShell = CreateObject("Shell.Application")
       
    '   Prompt for the folder
        Set objFolder = objShell.Namespace(GetDirectory)

        MsgBox FilePath

    End Sub

    Function GetDirectory(Optional Msg) As String
    '   Returns the directory specified by the user
        Dim bInfo As BROWSEINFO
        Dim path As String
        Dim r As Long, x As Long, pos As Integer
        Dim FileName
     

    '   Title in the dialog
        If IsMissing(Msg) Then
            bInfo.lpszTitle = "Selecione o diretório aonde estão as pastas de trabalho"
        Else
            bInfo.lpszTitle = Msg
        End If
       
    '   Type of directory to return
        bInfo.ulFlags = &H1

    '   Display the dialog
        x = SHBrowseForFolder(bInfo)
       
    '   Parse the result
        path = Space$(512)
        r = SHGetPathFromIDList(ByVal x, ByVal path)
        If r Then
            pos = InStr(path, Chr$(0))
            GetDirectory = Left(path, pos - 1)
        Else
            GetDirectory = ""
        End If
        FilePath = GetDirectory
    End Function

     

    Sub AbrirArquivosemDiretório()
    '****************************************************************

    'MACRO PARA ABERTURA DE CORREÇÃO DE TODOS OS ARQUIVOS DE UM

    'DIRETÓRIO QUE ATENDAM A UMA CONDIÇÃO DE NOME

    'Criada por; Adilson Soledade

    'Criada em: 16/05/2008

    '****************************************************************

     

    Dim Pasta As String, Arquivo As String, Chave


    Call FileInfo
    Pasta = FilePath
    Chave = "Quest"

    'O comando Dir exibe o nome dos arquivo do diretório Pasta

    Arquivo = Dir(Pasta & "*.xl?", vbNormal)
    'Comando para abrir o arquivo com base do nome da Pasta + Arquivo

    Workbooks.Open (Pasta & Arquivo)
    'Testa se o nome do arquivo se inicia com Chave

    If Left(Arquivo, Len(Chave)) = Chave Then

      'Acessa Worksheets(1) e auto ajusta as colunas A e B

      ActiveWorkbook.Worksheets(1).Columns("A:B").EntireColumn.AutoFit

       'Fecha o arquivo modificado e salva as alterações

           ActiveWorkbook.Close (True)

       'Loop para abertura dos demais arquivos do diretório com os mesmos comandos acima
      Do
      Arquivo = Dir()
        If Arquivo <> "" Then
          Workbooks.Open (Pasta & Arquivo)
          ActiveWorkbook.Worksheets(1).Columns("A:B").EntireColumn.AutoFit
          ActiveWorkbook.Close (True)
        End If

      Loop While Arquivo <> ""

     

    End If

     

    End Sub

     

     

     

    Muito Obrigado mais uma vez!

     

    Abraços

    segunda-feira, 19 de maio de 2008 13:18
  • Adilson

     

    Consegui com algumas alterações, muito obrigado novamente pela sua ajuda e como sempre digo se precisar de mim e estiver a meu alcance estou a disposição!

     

    Segue a macro:

     

    Code Snippet

    Option Explicit
    'API declarations
    Declare Function SHGetPathFromIDList Lib "shell32.dll" _
      Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) _
      As Long

    Declare Function SHBrowseForFolder Lib "shell32.dll" _
    Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long

    Public Type BROWSEINFO
        hOwner As Long
        pidlRoot As Long
        pszDisplayName As String
        lpszTitle As String
        ulFlags As Long
        lpfn As Long
        lParam As Long
        iImage As Long
    End Type

    Dim FilePath

     

     

     

    Sub AbrirArquivosemDiretório()
    '****************************************************************

    'MACRO PARA ABERTURA DE CORREÇÃO DE TODOS OS ARQUIVOS DE UM

    'DIRETÓRIO QUE ATENDAM A UMA CONDIÇÃO DE NOME

     

    'Criada por: Adilson Soledade

     

    'Criada em: 16/05/2008

    '****************************************************************

     

    Dim Pasta As String, Arquivo As String, Chave


    Call FileInfo
    Pasta = FilePath & "\"
    Chave = "Quest"

    'O comando Dir exibe o nome dos arquivo do diretório Pasta

    Arquivo = Dir(Pasta & "*.xl?", vbNormal)
    'Comando para abrir o arquivo com base do nome da Pasta + Arquivo

    Workbooks.Open (Pasta & Arquivo)
    'Testa se o nome do arquivo se inicia com Chave

    If Left(Arquivo, Len(Chave)) = Chave Then

      'Acessa Worksheets(1) e auto ajusta as colunas A e B

      ActiveWorkbook.Worksheets(1).Columns("A:B").EntireColumn.AutoFit

       'Fecha o arquivo modificado e salva as alterações

           ActiveWorkbook.Close (True)

       'Loop para abertura dos demais arquivos do diretório com os mesmos comandos acima
      Do
      Arquivo = Dir()
        If Arquivo <> "" Then
          Workbooks.Open (Pasta & Arquivo)
          ActiveWorkbook.Worksheets(1).Columns("A:B").EntireColumn.AutoFit
          ActiveWorkbook.Close (True)
        End If

      Loop While Arquivo <> ""

     

    End If

     

    End Sub

     

    Sub FileInfo()
        Dim c As Long, r As Long, i As Long
        Dim FileName As Object 'FolderItem2
        Dim objShell As Object 'IShellDispatch4
        Dim objFolder As Object 'Folder3
       
    '   Create the object
        Set objShell = CreateObject("Shell.Application")
       
    '   Prompt for the folder
        Set objFolder = objShell.Namespace(GetDirectory)

        MsgBox FilePath

    End Sub

     

     

    Function GetDirectory(Optional Msg) As String
    '   Returns the directory specified by the user
        Dim bInfo As BROWSEINFO
        Dim path As String
        Dim r As Long, x As Long, pos As Integer
        Dim FileName
     

    '   Title in the dialog
        If IsMissing(Msg) Then
            bInfo.lpszTitle = "Selecione o diretório aonde estão as pastas de trabalho"
        Else
            bInfo.lpszTitle = Msg
        End If
       
    '   Type of directory to return
        bInfo.ulFlags = &H1

    '   Display the dialog
        x = SHBrowseForFolder(bInfo)
       
    '   Parse the result
        path = Space$(512)
        r = SHGetPathFromIDList(ByVal x, ByVal path)
        If r Then
            pos = InStr(path, Chr$(0))
            GetDirectory = Left(path, pos - 1)
        Else
            GetDirectory = ""
        End If
        FilePath = GetDirectory
    End Function

     

     

    Muito Obrigado novamente se tiver sugestões por favor me informe.

    e muito obrigado a você tambem EvangelistaLion pela sua ajuda e atenção se precisar de ajuda e estiver a meu alcance peça e considere feito, muito obrigado.

     

    Abraços

    muito obrigado!

    segunda-feira, 19 de maio de 2008 13:36
  • Prezados,


    Gostaria do auxilio de vocês, meu caso é parecido com o do amigo acima, preciso listar os arquivos que estão numa pasta ate ai tudo bem, consegui com o codigo simples que o evangelista postou, mas agora queria listar os nomes desses arquivos em uma coluna.

    Depois gostaria de colocar em uma list box os nomes com o respectivo link que ao ser chamado abriria a planilha.

    alguem poderia me passar alguma dica? Se possivel comentada, pois estou estudando VBA e gostaria de entender todo o processo.

    Grato,

    Rogério

    quinta-feira, 9 de abril de 2009 14:14