Guru do Excel e Power BI

Boa noite, encontrei esse código na internet e ele faz exatamente o que eu preciso, porém ele faz um loop copiando os dados de varias planilhas (abas) de um mesmo arquivo, e preciso que ele copia apenas os dados da primeira planilha ( aba "CONSOLIDADO") de cada arquivo e cole em formato especial para valores, se alguém puder me ajudar ficarei muito agradecido.

'UnificarPlanilhas Macro
Sub lsUnificarPlanilhas()
On Error GoTo Sair

Dim lUltimaColunaAtiva As Long
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

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(lIPlan).Activate

lUltimaLinhaAtiva = Cells(Rows.Count, 1).End(xlUp).Row
lUltimaColunaAtiva = ActiveSheet.Cells(1, 5000).End(xlToLeft).Column

Set lRng = Range(Cells(1, lUltimaColunaAtiva).Address)

Range("A" & 1 & ":" & gfLetraColuna(lRng) & lUltimaLinhaAtiva).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!"

Sair:
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
.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

Olá Davi,

Sem um ambiente de testes, no teu caso as outras planilhas, não deu pra testar nada, mas vou te passar umas alterações baseadas apenas na análise do código, e assumindo que a questão se resume apenas a pegar de 1 única planilha, e colar especial.

• Apague as linhas
  For lIPlan = 1 To ActiveWorkbook.Sheets.Count
  Next lIPlan
• Altere a linha
  Workbooks(lNomeWB).Worksheets(lIPlan).Activate
  para
  Workbooks(lNomeWB).Worksheets("CONSOLIDADO").Activate
  Se é possível que essa planilha não exista em algum dos arquivos abertos, então é necessário implementar essa consistência.
• Logo abaixo da linha ActiveSheet.Paste
  inclua a linha Selection.Value = Selection.Value que é um "colar valores" mais simples

Dê retorno do funcionamento

Apenas para enriquecer, faço alguns comentários:

Há algumas atapas feitas em 3 ou 4 linhas, que poderiam ser feitas em 1 (mais complexa). Entendo que fez assim para ficar mais fácil de entender.

É possível eliminar a função gfLetraColuna se trocar as linhas
Set lRng = Range(Cells(1, lUltimaColunaAtiva).Address)
Range("A" & 1 & ":" & gfLetraColuna(lRng) & lUltimaLinhaAtiva).Select
Selection.Copy
pela linha
Range(Cells(1, "A"), Cells(lUltimaLinhaAtiva, lUltimaColunaAtiva)).Copy
pois você não precisa necessariamente do nome da coluna se usar o Cells; ele aceita indexar a coluna tanto pelo nome ("C" por exemplo) como por número (3 no caso da coluna "C"). Importante notar que a ordem dos elementos, comparado com o caso do RANGE("C5"), é invertido, ou seja, Cells(5,3) ou Cells(5,"C").

Não testei nada disso por falta de ambiente de testes.

Jimmy San Juan