Buenos días, soy nuevo en estoy de programar en excel, tengo un macro de evento de una lista desplegable, la cual si se le inserta un valor que no esta en la lista lo agrega automáticamente, aquí esta el código

Private Sub Worksheet_Change(ByVal Target As Range)

If Target.Address <> "$D$5" Then Exit Sub

On Error Resume Next

fil = Application.WorksheetFunction.Match(Target, Sheets("Hoja2").Columns("B:B"), 0)

If fil <> "" Then Exit Sub

uf = Sheets("Hoja2").Range("B" & Cells.Rows.Count).End(xlUp).Row + 1

Sheets("Hoja2").Range("B" & uf) = Target

Sheets("Hoja2").Range("B5:B" & uf).Sort Key1:=Sheets("Hoja2").Range("B5"), Order1:=xlAscending, Header:= _

xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _

DataOption1:=xlSortTextAsNumbers

End Sub

Bien esto funciona bien cuando se tiene una sola lista, pero cuando se tiene varias lista no se como hacer para que funcione, intente duplicar la rutina pero me tira un error,

Private Sub Worksheet_Change(ByVal Target As Range)

If Target.Address <> "$D$5" Then Exit Sub

On Error Resume Next

fil = Application.WorksheetFunction.Match(Target, Sheets("Hoja2").Columns("B:B"), 0)

If fil <> "" Then Exit Sub

uf = Sheets("Hoja2").Range("B" & Cells.Rows.Count).End(xlUp).Row + 1

Sheets("Hoja2").Range("B" & uf) = Target

Sheets("Hoja2").Range("B5:B" & uf).Sort Key1:=Sheets("Hoja2").Range("B5"), Order1:=xlAscending, Header:= _

xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _

DataOption1:=xlSortTextAsNumbers

End Sub

Private Sub Worksheet_Change(ByVal Target As Range)

If Target.Address <> "$D$9" Then Exit Sub

On Error Resume Next

fil = Application.WorksheetFunction.Match(Target, Sheets("Hoja2").Columns("D:D"), 0)

If fil <> "" Then Exit Sub

uf = Sheets("Hoja2").Range("D" & Cells.Rows.Count).End(xlUp).Row + 1

Sheets("Hoja2").Range("D" & uf) = Target

Sheets("Hoja2").Range("D5:D" & uf).Sort Key1:=Sheets("Hoja2").Range("D5"), Order1:=xlAscending, Header:= _

xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _

DataOption1:=xlSortTextAsNumbers

End Sub

subo el archivo, mas adelante se agregarán como 10 o 20 listas entonces no se como hacer para que se active dependiendo de la celta.

Gracias de antemano

ListaDiferenteHoja.rar

Hola:

No puede haber dos procedimientos con el mismo nombre, prueba así:

Private Sub Worksheet_Change(ByVal Target As Range):    On Error Resume Next


If Target.Address = "$D$5" Then

   fil = Application.WorksheetFunction.Match(Target, Sheets("Hoja2").Columns("B:B"), 0)

   If fil <> "" Then Exit Sub

   uf = Sheets("Hoja2").Range("B" & Cells.Rows.Count).End(xlUp).Row + 1

   Sheets("Hoja2").Range("B" & uf) = Target

   Sheets("Hoja2").Range("B5:B" & uf).Sort Key1:=Sheets("Hoja2").Range("B5"), Order1:=xlAscending, Header:= _

       xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _

       DataOption1:=xlSortTextAsNumbers

End If



If Target.Address = "$D$9" Then

   fil = Application.WorksheetFunction.Match(Target, Sheets("Hoja2").Columns("D:D"), 0)

   If fil <> "" Then Exit Sub

   uf = Sheets("Hoja2").Range("D" & Cells.Rows.Count).End(xlUp).Row + 1

   Sheets("Hoja2").Range("D" & uf) = Target

   Sheets("Hoja2").Range("D5:D" & uf).Sort Key1:=Sheets("Hoja2").Range("D5"), Order1:=xlAscending, Header:= _

       xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _

       DataOption1:=xlSortTextAsNumbers

End If



End Sub



[/CODE]

Saludos

Estaba loco con los condicionales, muchas gracias me funcionó perfecto