Te anexo la macro
Sub Obtener_Resultados()
'
' Por.Dante Amor
'
Application.ScreenUpdating = False
Set h1 = Sheets("MACRO")
Set h2 = Sheets("RESULTADOS")
Set h3 = Sheets("BASE DATOS")
'
If h1.AutoFilterMode Then h1.AutoFilterMode = False
h2.Rows("2:" & Rows.Count).ClearContents
'
For i = 2 To h1.Range("A" & Rows.Count).End(xlUp).Row
padre = h1.Cells(i, "A")
If h3.AutoFilterMode Then h3.AutoFilterMode = False
u3 = h3.Range("A" & Rows.Count).End(xlUp).Row
h3.Range("A1:G" & u3).AutoFilter Field:=1, Criteria1:=padre
u3 = h3.Range("A" & Rows.Count).End(xlUp).Row
u2 = h2.Range("A" & Rows.Count).End(xlUp).Row + 1
If u3 > 1 Then
h3.Range("A2:G" & u3).Copy
h2.Range("A" & u2).PasteSpecial xlValues
Else
h2.Range("A" & u2) = padre
h2.Range("B" & u2) = "No existe en la base de datos"
End If
Next
u2 = h2.Range("A" & Rows.Count).End(xlUp).Row
With h2.Range("H2:N" & u2)
.FormulaR1C1 = "=VLOOKUP(RC1,MACRO!C1:C8,COLUMN()-6,0)*RC7"
.Value = .Value
End With
If h3.AutoFilterMode Then h3.AutoFilterMode = False
h2.Select
Application.CutCopyMode = False
Application.ScreenUpdating = True
MsgBox "Fin Obtener Resultados"
End Sub
.
'S aludos. Dante Amor. Recuerda valorar la respuesta. G racias
.
Avísame cualquier duda
.