Usuário com melhor resposta
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.

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