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.

Question

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

Answer 1

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

Answer 2

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

Answer 3

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

Answer 4

Cara estou precisando de ajuda mesmo, abaixo colei um novo código que possa ser utilizado...

Abraço

Answer 5

Em qual linha você obteve erro?

---

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

Answer 6

'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)

Answer 7

A célula A3 está vazia?

---

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

Answer 8

Não, na verdade escolhi a célula A3 apenas para cortar o cabeçalho.

Att,

Cristiano

Answer 9

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

Answer 10

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

Answer 11

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