Te anexo el código
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(ActiveCell, Range("I30")) Is Nothing Then
If ([H28] = "" Or [H26] = "" Or [D16] = "" Or [D18] = "" Or [D30] = "") And Target.Value <> "" Then
Target.Value = ""
MsgBox "No has llenado todos los campos obligatorios del formulario. Debes llenar todos los datos antes de continuar.", vbCritical + vbOKOnly, "Sistema de Acuerdos Sociales beta"
End If
End If
'
'Por.Dante Amor
If Not Intersect(Target, Range("D6")) Is Nothing Then
If Target.Count > 1 Then Exit Sub
Range("D10") = ""
If Target.Value = "" Then Exit Sub
'
resp = Target.Value
Set h1 = ActiveSheet
Set h2 = Sheets("BaseDatosSubSolicitudes")
Set h3 = Sheets("temp")
h3.Cells.Clear
On Error Resume Next
ActiveWorkbook.Names("temp").Delete
On Error GoTo 0
'
j = 1
If h2.AutoFilterMode Then h2.AutoFilterMode = False
Set r = h2.Columns("R")
Set b = r.Find(resp, LookAt:=xlWhole)
If Not b Is Nothing Then
celda = b.Address
Do
'detalle
h3.Cells(j, "A") = h2.Cells(b.Row, "A")
j = j + 1
Set b = r.FindNext(b)
Loop While Not b Is Nothing And b.Address <> celda
End If
'
u3 = h3.Range("A" & Rows.Count).End(xlUp).Row
ActiveWorkbook.Names.Add Name:="temp", RefersToR1C1:="=Temp!R1C1:R" & u3 & "C1"
With Range("D10").Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:="=temp"
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
.ShowInput = True
.ShowError = True
End With
End If
'Fin.Por.Dante Amor
End Sub
.
'S aludos. Dante Amor. Recuerda valorar la respuesta. G racias
.
Avísame cualquier duda
.