Tente adaptar o codigo à suas necessides.

Sub Carrega_BD()
'Declaração de variaveis
Dim OldName As String, cSheet As String
Dim rw As Long, lw As Long
Dim sDir As String, sPath As String

'Determina o nome do arquivo corrente
OldName = ThisWorkbook.Name
'Determina o nome da sheet corrente
cSheet = ActiveSheet.Name
'Determina qual a ultima coluna preenchida no caso fixado em coluna A
rw = 1 'Cells(1, Cells.Columns.Count).End(xlToLeft).Column
'Determina qual a ultima linha da coluna A preenchida
lw = Cells(Cells.Rows.Count, "A").End(xlUp).Row
'Determina qual o caminho onde estão os arquivos (neste caso mo mesmo diretorio do arquivo corrente)
sPath = ThisWorkbook.Path 'Cells(1, 11)
'Acrescenta a barra invertida se necessario
If Right(sPath, 1) <> "" Then
    sPath = sPath & ""
    Else
    sPath = sPath
End If

'altera o diretorio de trabalho
ChDir sPath
'Começa a procurar arquivos com extensão xls
sDir = Dir("*.xls?")
'Inicia o loop até que não mais encontre arquivos
Do While sDir <> ""
           'Comparação para excluir o arquivo corrente da "pesquisa"
           If sDir <> OldName Then
              'Congela a tela para o usuario e abre o arquivo localizado
              Application.DisplayAlerts = False
              Application.ScreenUpdating = False
              Workbooks.Open Filename:=sDir, UpdateLinks:=0
              lw = lw + 1
                 Workbooks(OldName).Sheets(cSheet).Cells(lw, rw) = Workbooks(sDir).Sheets("Plan1").Cells(1, 1).Value
                
'Fecha o arquivo sem salvar
            Workbooks(sDir).Close SaveChanges:=False
            sDir = Dir
            Else
            Exit Sub
            End If
Loop
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub

Obrigado Reinaldo.

Está um pouco difícil para mim entender, vou dar uma estudada.

Abraços.

Reinlado, no caso abaixo, vc saberia como fazer para colar as células B17, B19 e B24 na linha 1. Do jeito que eu fiz as três células são coladas nas colunas A, B e C.

Abraços.

'
Sheets("800001").Select
Range("B17,B19,B24").Select
Selection.Copy
ActiveWorkbook.Worksheets.Add
Range("A1:C1").Select
ActiveSheet.Paste
With ActiveSheet
.Move after:=Worksheets(Worksheets.Count)
End With
With ActiveSheet
.Name = "800001A"
End With

Qdo é copiada uma range mesmo que não consecutiva, ao "colar" a mesma é inserida sequencialmente.
Então se quiser cd uma em um local especifico deve copiar/colar uma a uma. Agora se quiser que fiquem somente em B (B1,B2,B3) selecione somente a primeira B1

n serve isso?

=INDIRETO(LIN(A1) & "!A1")

e copia pra baixo