Este fórum está sendo desativado

[Renaut]

Olá tudo bem?
Fiz uma macro onde a ideia é:
Dentro de um diretório tenho N arquivos (pode ser 5, 10, 50). Tenho uma tabela oculta chamanda "AGENDA" e preciso copiar somente a linha 7 dessa agenda de cada um dos arquivos, formando assim uma lista geral.
Então a macro precisa:
Entrar no diretório, abrir todos os arquivos reexibir a sheet "Agenda", copiar a linha 7 de cada um dos arquivos e listar essa linha uma abaixo da outra.

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

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

PlanilhaDestino = ThisWorkbook.Name
sPath = Localizar_Caminho

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

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

'lNomeWB = ActiveWorkbook.Name

With Workbooks(sName).Worksheets("Agenda")
Worksheets("Agenda").Visible = True
'Determina ultima linha e coluna do arquivo Fonte (recem aberto)
lUltimaLinhaAtiva = .Cells(Rows.Count, 1).End(xlUp).Row
lUltimaColunaAtiva = .Cells(4, 5000).End(xlToLeft).Column
strcel1 = Cells(1, 1).Address
strcel2 = Cells(lUltimaLinhaAtiva, lUltimaColunaAtiva).Address
'Determina ultima linha do arquivo destino
lUltimaLinhaPlanDestino = Workbooks(PlanilhaDestino).Worksheets(1).Cells(Rows.Count, 1).End(xlUp).Row
If lUltimaLinhaPlanDestino > 1 Then lUltimaLinhaPlanDestino = Cells(Rows.Count, 1).End(xlUp).Row + 1

Set lRng = Range(Cells(1, 1).Address & ":" & Cells(lUltimaLinhaAtiva, lUltimaColunaAtiva).Address)
lRng.Copy Destination:=Workbooks(PlanilhaDestino).Worksheets(1).Range("A7" & lUltimaLinhaPlanDestino)
'Fecha o arqivo Fonte
End With
Workbooks(sName).Close SaveChanges:=False
sName = Dir()
Loop

MsgBox "Planilhas unificadas!"

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

Abre o diretorio
Public Function Localizar_Caminho() As String

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

'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

[Renaut]

Obrigado pelas respostas, olham outros casos mas.......

[AfonsoMira]

Olá @Renaut.
Então, sempre fica mais fácil para nós ajudar quando anexa o seu ficheiro/s para nós podermos testar as macros sem que tenhamos que criar todos os ficheiros do início.

Lembrando, que muitos aqui que ajudam, ajudam na sua hora vaga.

Veja se é isto que pretende:

Código: Selecionar todos

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

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

PlanilhaDestino = ThisWorkbook.Name
sPath = Localizar_Caminho

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

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

'lNomeWB = ActiveWorkbook.Name

Workbooks(sName).Worksheets("Agenda").Visible = True
'Determina ultima linha do arquivo destino
lUltimaLinhaPlanDestino = Workbooks(PlanilhaDestino).Worksheets(1).Cells(Rows.Count, 1).End(xlUp).Row
If lUltimaLinhaPlanDestino > 1 Then lUltimaLinhaPlanDestino = Cells(Rows.Count, 1).End(xlUp).Row + 1
Workbooks(sName).Worksheets("Agenda").Select
Workbooks(sName).Worksheets("Agenda").Rows(7).Select
Selection.Copy
Workbooks(PlanilhaDestino).Worksheets(1).Range("A" & lUltimaLinhaPlanDestino).PasteSpecial
Application.CutCopyMode = False
'Fecha o arqivo Fonte
Workbooks(sName).Close SaveChanges:=False
sName = Dir()
Loop

MsgBox "Planilhas unificadas!"

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

'Abre o diretorio
Public Function Localizar_Caminho() As String

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

'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