Este fórum está sendo desativado

[Renaut]

Olá Pessoal,
Estou criando um VBA onde eu tenho em um diretório 30 arquivos de Excel onde nele tem uma Plan chamada tabela de Dados, preciso compilar essa tabela de dados dos 30 arquivos em um só, como uma lista de dados um abaixo do outro.

Fiz o codigo abaixo e funcionou para 1 arquivo, mas apartir do segundo não estou conseguindo identificar uma forma de minimizar o código para que ele faça a leitura dos arquivos e copie.

Fico agradecido se puderem avaliar e me ajudar.

Sub copiar()
Dim wsOrigem As Worksheet
Dim wsDestino As Worksheet


Workbooks.Open Filename:="\Documents\Teste\1.xlsm"
Sheets("Tabela Dados ").Visible = True
Sheets("Tabela Dados ").Activate
Range("b5:bk16").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False

Set wsOrigem = Workbooks("1.xlsm").Worksheets("Tabela Dados ")

Set wsDestino = ThisWorkbook.Sheets("Planilha1")

With wsOrigem
Range("b5:bk16").Copy Destination:=wsDestino.Range("A2:CU100000")

End With
wsDestino.Activate

wsDestino.Range("A1048576").End(xlUp).Offset(1, 0).Select
Workbooks("1.xlsm").Close SaveChanges:=False
End Sub

[Renaut]

Bom dia
Caros dei uma melhorada no código, só que a Tabela de Dados tem apenas 7 linhas para cada arquivo que ele copia, só que eu fiz o teste com 2 arquivos e ele esta retornando a copia dos 2 mas multiplicando por muitas vezes o numero de linhas, deveria ter colado 14 linhas e vieram mais de 300.

Se algum colega puder avaliar. agradeço

Sub lsUnificarPlanilhas()


Dim lUltimaLinhaAtiva As Long
Dim lRng As Range
Dim sPath As String
Dim fName As String
Dim lNomeWB As String
Dim lIPlan As Integer
Dim lUltimaLinhaPlanDestino As Long
Dim A As Worksheets

PlanilhaDestino = ThisWorkbook.Name
sPath = Localizar_Caminho

sName = Dir(sPath & "\*.xl*")

Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual

Do While sName <> ""
fName = sPath & "\" & sName
Workbooks.Open Filename:=fName, UpdateLinks:=False

lNomeWB = ActiveWorkbook.Name

For lIPlan = 1 To ActiveWorkbook.Sheets.Count

Workbooks(lNomeWB).Worksheets("Tabela Dados ").Visible = True
Workbooks(lNomeWB).Worksheets("Tabela Dados ").Activate
ActiveWorkbook.Sheets("Tabela Dados ").Select
lUltimaLinhaAtiva = Cells(Rows.Count, 1).End(xlUp).Row
lUltimaColunaAtiva = ActiveSheet.Cells(1, 5000).End(xlToLeft).Column

Set lRng = Range(Cells(1, lUltimaColunaAtiva).Address)
Range("b5:bk16").Select
Selection.Copy


Workbooks(PlanilhaDestino).Worksheets(1).Activate

lUltimaLinhaPlanDestino = Cells(Rows.Count, 1).End(xlUp).Row

If lUltimaLinhaPlanDestino > 1 Then
lUltimaLinhaPlanDestino = Cells(Rows.Count, 1).End(xlUp).Row + 1
End If

Range("A" & lUltimaLinhaPlanDestino).Select

ActiveSheet.Paste
Application.CutCopyMode = False
Next lIPlan

Workbooks(lNomeWB).Close SaveChanges:=False
sName = Dir()
Loop

MsgBox "Planilhas unificadas!"


Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
End Sub

Function gfLetraColuna(ByVal rng As Range) As String
Dim lTexto() As String

lTexto = Split(rng.Address, "$")

gfLetraColuna = lTexto(1)
End Function

Public Function Localizar_Caminho() As String

Dim strCaminho As String
With Application.FileDialog(msoFileDialogFolderPicker)
'Permitir mais de uma pasta


'Mostrar janela
.Show

If .SelectedItems.Count > 0 Then
strCaminho = .SelectedItems(1)
End If

End With

'Atribuir caminho a variável
Localizar_Caminho = strCaminho
End Function

[osvaldomp]

A minha sugestão é de você deixar de lado o código que você está tentando utilizar e desenvolver outro. Se houver interesse responda inicialmente as questões abaixo.

1. qual o nome da planilha destino dos dados ?
2. qual o endereço da pasta que contém os 30 arquivos origem dos dados ?
3. na pasta origem estão somente os 30 arquivos de interesse ? se não, é possível deixar uma pasta com somente aqueles arquivos ?
4. os nomes dos arquivos origem dos dados seguem uma máscara ? ex: Arquivo1, Arquivo2, Arquivo3, ...
5. quais as extensões dos arquivos origem ? ex: todos "xls", todos "xlsx", todos "xlsm", ou misturados ?
6. os nomes das planilhas origem são iguais em todos os arquivos ? qual o nome ?
7. a planilha origem é única em cada arquivo origem ?
8. a quantidade de linhas a ser copiada é fixa ? serão sempre 7 linhas ? qual a primeira linha a ser copiada ?
9. a quantidade de colunas a ser copiada é fixa ? qual a primeira coluna a ser copiada ? suponho que na planilha destino haja cabeçalhos de colunas, qual a última coluna com cabeçalho ?
10. o intervalo a ser copiado contém fórmulas ?

[Renaut]

Olá obrigado pelo retorno,
sim concordo com você quanto mais simples mais facil de ser ajudado.

Veja coloquei um anexo, onde tenho 2 arquivos no diretorio "Base do Teste" pode ser que tenha os 30/10/20 independente da quantidade sempre será o mesmo formato de planilha. Dentro deles tem a a Plan "Tabela Dados ". Preciso copiar apartir da linha 5 o conteúdo dessa plan e levar para o arquivo Macro VBA. Então será feito essa leitura dos arquivos no diretorio e retornar especificamente os dados dessa plan que será igual para todos os arquivos.

Att
Renato

[Renaut]

Respondendo as questoes:
1 - Macro VBA
2 - Diretorios no arquivo compactados
3 - No diretorio sempre estará os arquivos do mesmo formato, mas pode variar a quantidade
4- Sempre será o mesmo nome "Tabela Dados "
5- Xslm
6- Sim, Tabela Dados
7- Não terei outras dezenas de abas com nomes diferentes
8- Sim sempre fixa, veja modelo arquivo 1 nao considerar cabeçalho
9- sim sempre fixa
10 - Sim contem formulas.

Att
Renato

[Reinaldo]

A estrutura dos 2 arquivos (1.xlsx e 2.xlsx são divergentes)

crossPosthttps://www.tomasvasquez.com.br/forum/v ... 611#p25611

[Renaut]

boa tarde
Segue arquivos alinhados. Especificamente a macro deve copiar somente os dados da aba "Tabela Dados".

Obrigado
Renato

[gfranco]

Amigo,
veja se é isso que precisa.