Ola Segue um codigo para você adaptar troque os nomes das planilhas e celulas:
Sub Pesquisar()
Dim sDir As String, sPath As String, R As Long
'começando na ultima linhavazia da planilha
R = Sheets("2013").Cells(Rows.Count, 1).End(xlUp).Row + 1 'Altere o nome da planilha que ira receber os dados
'Path (Diretorio) -colocar esta planilha fora da pasta que sera feito a pesquisa dos orçamentos
sPath = ThisWorkbook.Path & "1 Orcamento Usinagem Externa" ' nome da pasta aonde você ira colocar todas as planilhas a serem pesquisadas
'Acrescenta a "" se necessario
If Right(sPath, 1) <> "" Then
sPath = sPath & ""
Else
sPath = sPath
End If
'altera temporariamente o diretorio de trabalho
ChDir sPath
'Procura por qq arquivo que tenha "xlsm" na extensão
sDir = Dir("*.xlsm")
'Executa enquanto encontrar algum arquivo
Do While sDir <> ""
'Verifica se o nome encontrado não é o da planilha ativa
If sDir <> ThisWorkbook.Name Then
'Lê eColoca o Valor na Celula
Sheets("2013").Cells(R, 1).Formula = GetInfoFromClosedFile(sPath, sDir, "Fornecedor", "B5") 'nome da planilha que estão os seus dados e a linha que deseja copiar
Sheets("2013").Cells(R, 2).Formula = GetInfoFromClosedFile(sPath, sDir, "Fornecedor", "B3")
Sheets("2013").Cells(R, 6).Formula = GetInfoFromClosedFile(sPath, sDir, "Fornecedor", "B4")
Sheets("2013").Cells(R, 7).Formula = GetInfoFromClosedFile(sPath, sDir, "Fornecedor", "D3")
sDir = Dir
End If
R = R + 1
Loop
'trata uma possivel tentativa de excluir planilhas quando a pasta estiver vazia
On Error GoTo Trata_Erro
'deletar planilhas apos copiar dados
'Kill ("*.xlsm")
Exit Sub
Trata_Erro:
MsgBox "A pasta Esta Vazia" & Chr(13) & "Ja foram IMPORTADOS todos os Valores.", 48, "Problemas Ligue: 99951565"
End Sub
Private Function GetInfoFromClosedFile(ByVal wbPath As String, wbName As String, wsName As String, cellRef As String) As Variant
Dim arg As String
GetInfoFromClosedFile = ""
If Right(wbPath, 1) <> "" Then wbPath = wbPath & ""
arg = "'" & wbPath & "[" & wbName & "]" & _
wsName & "'!" & Range(cellRef).Address(True, True, xlR1C1)
On Error Resume Next
GetInfoFromClosedFile = ExecuteExcel4Macro(arg)
End Function
Postado : 27/02/2013 1:01 pm