none
Acrescentar a uma macro que copia um intervalo de uma planilha de varios arquivos para outra pasta de trabalho, um código trazendo o nome do arquivo de origem em cada linha. RRS feed

  • Pergunta

  • Tenho o código abaixo que realiza a operação que necessito, porém preciso acrescentar uma nova instrução na qual o mesmo código além de copiar traga na próxima coluna livre e em cada linha copiada o nome do arquivo de origem (repetindo apenas para o item daquela planilha) e assim sucessivamente.

    Sub Consolidar()
        Dim Pasta As String
        Dim Arquivo As String
        
        'Seleciona a pasta do Windows onde estão todas as
        'pastas de trabalho a serem copiadas
        With Application.FileDialog(msoFileDialogFolderPicker)
            .Show
            Pasta = .SelectedItems(1)
        End With
        
        'Armazena o nome do primeiro arquivo (pasta de trabalho) na variável "Arquivo"
        Arquivo = Dir(Pasta & "\" & "*.xls*")
        
        'Laço para para percorrer todos os arquivos da pasta do windows
        Do
            
            'Abre o arquivo
            Workbooks.Open (Pasta & "\" & Arquivo)
            
            'Copia a região adjacente à celula A3 para a planilha de consolidação
            [A3].CurrentRegion.Copy ThisWorkbook.ActiveSheet.Cells(Cells.Rows.Count, "A").End(xlUp).Offset(1, 0)
            
            'Fecha o arquivo
            Workbooks(Arquivo).Close False
                    
            'Lista o próximo arquivo
            Arquivo = Dir
        Loop While Arquivo <> ""
        
        Application.CutCopyMode = False
        
        MsgBox "Fim de Execução da Macro"
        
    End Sub

    Att,

    Cristiano Tomadon



    • Editado Tomadon terça-feira, 24 de setembro de 2013 02:27 Edição do titulo
    quarta-feira, 18 de setembro de 2013 11:58

Respostas

  • Olá Felipe,

    Infelizmente não poderei disponiblizar os arquivos, devido as políticas da empresa onde trabalho.

    Mas de qualquer forma desenvolvi em uma solução para o meu problema no código abaixo, apenas limitando a quantidade de colunas.

    Sub Consolidar_2()
        Dim Pasta As String
        Dim Arquivo As String
        Dim r As Long, rTemp As Long
        Dim shPadrao As Worksheet
                    
        'Seleciona a pasta do Windows onde estão todas as
        'pastas de trabalho a serem copiadas
        With Application.FileDialog(msoFileDialogFolderPicker)
            .Show
            Pasta = .SelectedItems(1)
        End With
        
        'Armazena o nome do primeiro arquivo (pasta de trabalho) na variável "Arquivo"
        Arquivo = Dir(Pasta & "\" & "*.xls*")
        
        Set shPadrao = Sheets("Plan1")
            
        'Laço para para percorrer todos os arquivos da pasta do windows
        Do
            
            'Abre o arquivo
            Workbooks.Open (Pasta & "\" & Arquivo)
            
            'Acha a ultima linha utilizada na planilha onde serao colados os dados
            r = shPadrao.Cells(Rows.Count, "A").End(xlUp).Row
            'Descubro sua quantas linhas ele possui
            rTemp = ActiveWorkbook.ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row
            'Colo na planilha principal
            ActiveWorkbook.ActiveSheet.Range("A2:L" & rTemp).Copy shPadrao.Range("A" & r + 1)
            'Insiro o Nome do Arquivo
            shPadrao.Range("M" & r + 1, "M" & r + rTemp - 1).Value = Arquivo
                  
            'Fecha o arquivo
            Workbooks(Arquivo).Close False
                    
            'Lista o próximo arquivo
            Arquivo = Dir
        Loop While Arquivo <> ""
        
        Application.CutCopyMode = False
        
        MsgBox "Fim de Execução da Macro"
        
    End Sub

    Att,

    Cristiano Tomadon

    • Marcado como Resposta Tomadon segunda-feira, 7 de outubro de 2013 17:23
    segunda-feira, 7 de outubro de 2013 17:22

Todas as Respostas

  • Alterei um bloco do seu código para o mostrado abaixo:

    Set wksThis = ActiveSheet
    lngRow = 1
    Do
        
        'Abre o arquivo
        Set wkb = Workbooks.Open(Pasta & "\" & Arquivo)
        
        'Copia a região adjacente à celula A3 para a planilha de consolidação
        wkb.Range("A3").CurrentRegion.Copy wksThis.Cells(Cells.Rows.Count, "A").End(xlUp).Offset(1, 0)
        
        With wksThis.UsedRange
            lngLastCol = .Cells(.Cells.Count).Column + 1
            lngLastRow = .Cells(.Cells.Count).Row
        End With
        wksThis.Cells(lngRow, lngLastCol).Resize(lngLastRow - lngRow + 1) = 1 'wkb.FullName
        lngRow = lngLastRow + 1
                
        'Fecha o arquivo
        wkb.Close False
                
        'Lista o próximo arquivo
        Arquivo = Dir
    Loop While Arquivo <> ""


    Felipe Costa Gualberto - http://www.ambienteoffice.com.br

    sexta-feira, 20 de setembro de 2013 10:17
    Moderador
  • Tentei substituir pelo seu código porém ocorreu "erro 438"

    Sub Consolidar_3()
        Dim Pasta As String
        Dim Arquivo As String
        Dim wkb As Workbook
        Dim wksThis As Worksheet
        Dim IngRow As Long
        Dim IngLastCol As Long
        Dim IngLastRow As Long
            
        'Seleciona a pasta do Windows onde estão todas as
        'pastas de trabalho a serem copiadas
        With Application.FileDialog(msoFileDialogFolderPicker)
            .Show
            Pasta = .SelectedItems(1)
        End With
        
        'Armazena o nome do primeiro arquivo (pasta de trabalho) na variável "Arquivo"
        Arquivo = Dir(Pasta & "\" & "*.xls*")
        
      Set wksThis = ActiveSheet
    lngRow = 1
    Do
        
        'Abre o arquivo
        Set wkb = Workbooks.Open(Pasta & "\" & Arquivo)
        
        'Copia a região adjacente à celula A3 para a planilha de consolidação
        wkb.Range("A3").CurrentRegion.Copy wksThis.Cells(Cells.Rows.Count, "A").End(xlUp).Offset(1, 0)
        
        With wksThis.UsedRange
            lngLastCol = .Cells(.Cells.Count).Column + 1
            lngLastRow = .Cells(.Cells.Count).Row
        End With
        wksThis.Cells(lngRow, lngLastCol).Resize(lngLastRow - lngRow + 1) = 1 'wkb.FullName
        lngRow = lngLastRow + 1
                
        'Fecha o arquivo
        wkb.Close False
    
            'Lista o próximo arquivo
            Arquivo = Dir
        Loop While Arquivo <> ""
        
        Application.CutCopyMode = False
        
        MsgBox "Fim de Execução da Macro"
        
    End Sub
    

    sexta-feira, 20 de setembro de 2013 15:31
  • Também podemos utilizar o código abaixo:

    Sub Consolidar_2()
        Dim Pasta As String
        Dim Arquivo As String
        Dim r As Long, rTemp As Long
        Dim shPadrao As Worksheet
        
        'Seleciona a pasta do Windows onde estão todas as
        'pastas de trabalho a serem copiadas
        With Application.FileDialog(msoFileDialogFolderPicker)
            .Show
            Pasta = .SelectedItems(1)
        End With
        
        'Armazena o nome do primeiro arquivo (pasta de trabalho) na variável "Arquivo"
        Arquivo = Dir(Pasta & "\" & "*.xls*")
        
        Set shPadrao = Sheets("Plan1")
            
        'Laço para para percorrer todos os arquivos da pasta do windows
        Do
            
            'Abre o arquivo
            Workbooks.Open (Pasta & "\" & Arquivo)
            
           'Acha a ultima linha utilizada na planilha onde serao colados os dados
            r = shPadrao.Cells(Rows.Count, "A").End(xlUp).Row
            'Descubro sua quantas linhas ele possui
            rTemp = ActiveWorkbook.ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row
            'Colo na planilha principal
            ActiveWorkbook.ActiveSheet.Range("A2:L" & rTemp).Copy shPadrao.Range("A" & r + 1)
    
            
            'Fecha o arquivo
            Workbooks(Arquivo).Close False
                    
            'Lista o próximo arquivo
            Arquivo = Dir
        Loop While Arquivo <> ""
        
        Application.CutCopyMode = False
        
        MsgBox "Fim de Execução da Macro"
        
    End Sub


    terça-feira, 24 de setembro de 2013 02:30
  • Cara estou precisando de ajuda mesmo, abaixo colei um novo código que possa ser utilizado...

    Abraço

    terça-feira, 24 de setembro de 2013 02:34
  • Em qual linha você obteve erro?

    Felipe Costa Gualberto - http://www.ambienteoffice.com.br

    quarta-feira, 2 de outubro de 2013 00:38
    Moderador
  • 'Copia a região adjacente à celula A3 para a planilha de consolidação
        wkb.Range("A3").CurrentRegion.Copy wksThis.Cells(Cells.Rows.Count, "A").End(xlUp).Offset(1, 0)

    quarta-feira, 2 de outubro de 2013 11:33
  • A célula A3 está vazia?

    Felipe Costa Gualberto - http://www.ambienteoffice.com.br

    sexta-feira, 4 de outubro de 2013 03:50
    Moderador
  • Não, na verdade escolhi a célula A3 apenas para cortar o cabeçalho.

    Att,

    Cristiano

    sexta-feira, 4 de outubro de 2013 11:39
  • Não sei o que pode estar acontecendo.

    Poderia disponibilizar sua pasta de trabalho original e uma das que estão para ser abertas para download?


    Felipe Costa Gualberto - http://www.ambienteoffice.com.br

    segunda-feira, 7 de outubro de 2013 02:42
    Moderador
  • Olá Felipe,

    Infelizmente não poderei disponiblizar os arquivos, devido as políticas da empresa onde trabalho.

    Mas de qualquer forma desenvolvi em uma solução para o meu problema no código abaixo, apenas limitando a quantidade de colunas.

    Sub Consolidar_2()
        Dim Pasta As String
        Dim Arquivo As String
        Dim r As Long, rTemp As Long
        Dim shPadrao As Worksheet
                    
        'Seleciona a pasta do Windows onde estão todas as
        'pastas de trabalho a serem copiadas
        With Application.FileDialog(msoFileDialogFolderPicker)
            .Show
            Pasta = .SelectedItems(1)
        End With
        
        'Armazena o nome do primeiro arquivo (pasta de trabalho) na variável "Arquivo"
        Arquivo = Dir(Pasta & "\" & "*.xls*")
        
        Set shPadrao = Sheets("Plan1")
            
        'Laço para para percorrer todos os arquivos da pasta do windows
        Do
            
            'Abre o arquivo
            Workbooks.Open (Pasta & "\" & Arquivo)
            
            'Acha a ultima linha utilizada na planilha onde serao colados os dados
            r = shPadrao.Cells(Rows.Count, "A").End(xlUp).Row
            'Descubro sua quantas linhas ele possui
            rTemp = ActiveWorkbook.ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row
            'Colo na planilha principal
            ActiveWorkbook.ActiveSheet.Range("A2:L" & rTemp).Copy shPadrao.Range("A" & r + 1)
            'Insiro o Nome do Arquivo
            shPadrao.Range("M" & r + 1, "M" & r + rTemp - 1).Value = Arquivo
                  
            'Fecha o arquivo
            Workbooks(Arquivo).Close False
                    
            'Lista o próximo arquivo
            Arquivo = Dir
        Loop While Arquivo <> ""
        
        Application.CutCopyMode = False
        
        MsgBox "Fim de Execução da Macro"
        
    End Sub

    Att,

    Cristiano Tomadon

    • Marcado como Resposta Tomadon segunda-feira, 7 de outubro de 2013 17:23
    segunda-feira, 7 de outubro de 2013 17:22
  • Que bom que arrumou uma solução.

    Em relação à disponibilizar pastas de trabalho, muitas pessoas mudam os valores para outros fictícios, mudam descrições, etc. Na próxima vez, se for possível, pode tentar fazer isso.


    Felipe Costa Gualberto - http://www.ambienteoffice.com.br

    terça-feira, 8 de outubro de 2013 22:27
    Moderador