Preciso de uma ajuda, tenho uma situação onde na planilha "relatório" tenho uma relação de ativos na qual preciso realizar uma busca por ativo, dentre as planilhas "dados" para identificar as informações e posteriormente copiar as informações localizadas e colar numa sheet separada na planilha "relatório".
Até então elaborei o seguinte código:
Código: Selecionar todos
Sub importar_dados()
Application.ScreenUpdating = False
Dim wsDestino As Worksheet
Dim wsOrigem As Workbook
Dim wsArquivo As Variant
Dim wsLoop As Integer
Dim wsNomeArquivo As String
Dim wsLinhaFinal As Long
Dim wsBaseDados As Worksheet
Dim wsLinha As Long
'Loop dos arquivos
wsArquivo = Application.GetOpenFilename("Arquivo do Excel (*.xls), *.xl*", _
Title:="Escolha o arquivo a ser importado", _
MultiSelect:=True)
If Not IsArray(wsArquivo) Then
If wsArquivo = "" Or wsArquivo = False Then
MsgBox "Processo abortado, nenhum arquivo foi escolhido", vbOKOnly, "Processo abortado"
Exit Sub
End If
End If
Set wsDestino = Sheets("NF")
Set wsBaseDados = Sheets("AR_Jan")
'Loop para importação dos arquivos
For wsLoop = LBound(wsArquivo) To UBound(wsArquivo)
wsLinha = 3
wsNomeArquivo = wsArquivo(wsLoop)
Application.Workbooks.Open (wsNomeArquivo)
Set wsOrigem = ActiveWorkbook
With wsOrigem
wsUltimaLinha = ActiveSheet.Cells(Rows.Count, "B").End(xlUp).Row + 1
While wsBaseDados.Range("A" & wsLinha).Value <> Empty
wsLinhaFinal = wsDestino.Cells(Rows.Count, "B").End(xlUp).Row + 2
ActiveSheet.Range("$B$2:$D$" & wsUltimaLinha).AutoFilter Field:=1, Criteria1:=wsBaseDados.Range("A" & wsLinha)
ActiveSheet.Range("$B$2:$D$" & wsUltimaLinha).AutoFilter Field:=1, Criteria1:=wsBaseDados.Range("A" & wsLinha)
ActiveSheet.Range("$B$2:$AG$2").Select
ActiveSheet.Range(Selection, Selection.End(xlDown)).Select
Selection.SpecialCells(xlCellTypeVisible).Select
Selection.Copy
wsDestino.Range("B" & wsLinhaFinal).PasteSpecial xlPasteValues
wsLinha = wsLinha + 1
wsOrigem.ActiveSheet.Range("$B$2:$D$" & wsUltimaLinha).AutoFilter Field:=1
Wend
End With
Application.DisplayAlerts = False
ActiveWorkbook.Close savechanges:=False
Application.DisplayAlerts = True
Next wsLoop
wsBaseDados.Range("B1").Select
MsgBox "Importação concluída"
Application.ScreenUpdating = True
End Sub
Poderiam me auxiliar? Os arquivos para testes encontram-se em anexo.