Ejecutar macro según el valor de la celda

Que tal necesito de su valiosa ayuda tengo que ejecutar una macro en automático esto depende del valor de la celda.
Estoy utilizando la siguiente macro:
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
If Target.Address = "$S$1" And Target.Value = 1 Then
'Aqui pones la macro a ejecutar
Macro1
End If
If Target.Address = "$S$1" And Target.Value = 16 Then
'Aqui pones la macro a ejecutar
Macro2
End If
End Sub
No me reconoce en la celda S1 el Valor 1 y 16 si pongo manuem estos numero ejecuta la macro pero como los tengo relacionados con fórmula, no me reconoce los valores.
Sin más por el momento y ciomo siempre agradeciendo su ayuda.

1 respuesta

Respuesta
1
Prueba este otro código:
'----------------
Private Sub Worksheet_Calculate()
   Select Case Range("S1").Value
      Case 1
         MsgBox "se ejecuta macro 1"
      Case 16
         MsgBox "se ejecuta macro 2"
   End Select
End Sub
'----------------
Donde pone msgbox "se ejecuta macro... tú colocas tú macro respectiva la nº1 o nº 2
(Recuerda, si das por terminada la pregunta, cierra y valora)
Gracias por la pronta respuesta, ahora tengo más dudas
1.- Lo Copie en la hoja de calclulo a ocupar
2.- Le agregue la macro pero no me funciona
Sub BuscayAgrega()
'
' BuscayAgrega Macro
'
' Acceso directo: CTRL+k
'
Dim CONTRATO As Range
  For Each CONTRATO In ActiveSheet.Range("N1")
  If CONTRATO = "" Then
  MsgBox "Falta numero de contrato"
  Range("N1").Select
  Exit Sub
  End If
  Next
 Dim Vacio As Range
  For Each Vacio In ActiveSheet.Range("H1")
  If Vacio = "" Then
  Range("H1").Select
  Exit Sub
  End If
  Next
Dim lngUltimaFila As Long
Dim strObjetoBuscar As String
Dim lngResultado As Long
Dim lngColumna As Long, lngFila As Long
Dim lngPegarColumna As Long, lngPegarFila As Long
Dim x As Integer, n As Integer
Sheets("Cartera").Select
'quitar resultados anteriores
Range("F3:K5000").ClearContents
'columna + fila donde empezar/terminar búsqueda
lngColumna = 1
lngFila = 3
lngUltimaFila = Columns(lngColumna). _
  Range("A5000").End(xlUp).Row
'columna + fila donde empezar a pegar resultados
lngPegarColumna = 6
lngPegarFila = 3
'objeto a buscar
strObjetoBuscar = Range("H1").Text
If strObjetoBuscar = "" Then GoTo 99
'minúsculas
strObjetoBuscar = LCase(strObjetoBuscar)
'bucle: realizar búsqueda
For n = lngFila To lngUltimaFila
  'evaluación
  lngResultado = InStr(1, Cells(n, 1), _
     strObjetoBuscar, vbTextCompare)
    'copiar/pegar
    If lngResultado > 0 Then
     Range(Cells(n, 1), Cells(n, 4)).Copy
      Range( _
      Cells(lngPegarFila, lngPegarColumna), _
      Cells(lngPegarFila, lngPegarColumna + 2)) _
        .Select
      ActiveSheet.Paste
    lngPegarFila = lngPegarFila + 1
    End If
Next n
'aparcar
Application.CutCopyMode = False
Range("F3").Select
99:
Dim Cambios As Range
  For Each Cambios In ActiveSheet.Range("L3")
   If Cambios = 0 Then
   MsgBox "No existe Registro"
   Range("H1").Select
   Exit Sub
   End If
   Next
   Sheets("Relacion").Select
   Dim Registros As Range
   For Each Registros In ActiveSheet.Range("H63")
   If Registros = 2 Then
   MsgBox "Ya Existe en la relacion"
   Sheets("Cartera").Select
   Range("H1:K1").ClearContents
   Range("H1").Select
   Exit Sub
   End If
   Next
   Sheets("Cartera").Select
Dim numConsec As Long
Dim strConsec As String
Range("Q1").Select
Selection.NumberFormat = "@"
If IsEmpty(ActiveCell) Then
Range("Q1").Value = "0"
Else
numConsec = Val(Range("Q1").Value) + 1
strConsec = Right("0" & Trim(Str(numConsec)), 1)
Range("Q1").Value = strConsec
End If
Call CopyenRelacion
ActiveWorkbook.Save
End Sub
Sub CopyenRelacion()
'
' CopyenRelacion Macro
'
'
    Sheets("Relacion").Select
    Range("A63:E63").Select
    Selection.Copy
    Range("A61").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("A2:E61").Select
    Range("A61").Activate
    Application.CutCopyMode = False
    ActiveWorkbook.Worksheets("Relacion").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Relacion").Sort.SortFields.Add Key:=Range("A2:A998" _
        ), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Relacion").Sort
        .SetRange Range("A2:E61")
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Sheets("Cartera").Select
    Range("N2").Select
    'ActiveCell.FormulaR1C1 = "OK"
    Range("H1:K1").ClearContents
    Range("H1").Select
    End sub
Espero me puedas ayudar
Gracias
No entiendo muy bien lo que quieres, pero pod´ria ser algo así:
Cuando el valor de S1 es 1, se ejecuta la macro BuscayAgrega, pero si el valor de S1 es 16 se ejecuta la macro CopyenRelacion y si el valor de S1 es distinto a 1 o 16 no realiza ninguna acción.
El que ejecuta una u otra macro, tu tendrás que decirle el orden ya que yo es un dato que no conozco, pero como ejemplo te puede valer.
'------------------
Private Sub Worksheet_Calculate()
   Select Case Range("S1").Value
      Case 1
         BuscayAgrega
      Case 16
         CopyenRelacion
   End Select
End Sub ?
Perdón no me explique bien.
Al ejecutar automáticamente la macro que me pasaste todo va muy bien pero al llegar a ejecutar mi macro se regresa y no pasa de un solo punto.
Private Sub Worksheet_Calculate()
   Select Case Range("S1").Value
      Case 1
         BuscayAgrega
      Case 16
         CopyenRelacion
   End Select
End Sub ?
]Sub BuscayAgrega()
'
' BuscayAgrega Macro
'
' Acceso directo: CTRL+k
'
Dim CONTRATO As Range
  For Each CONTRATO In ActiveSheet.Range("N1")
  If CONTRATO = "" Then
  MsgBox "Falta numero de contrato"
  Range("N1").Select
  Exit Sub
  End If
  Next
 Dim Vacio As Range
  For Each Vacio In ActiveSheet.Range("H1")
  If Vacio = "" Then
  Range("H1").Select
  Exit Sub
  End If
  Next
Dim lngUltimaFila As Long
Dim strObjetoBuscar As String
Dim lngResultado As Long
Dim lngColumna As Long, lngFila As Long
Dim lngPegarColumna As Long, lngPegarFila As Long
Dim x As Integer, n As Integer
Sheets("Cartera").Select
Aqui es donde se regresa a ejecutar la macro "Private Sub Worksheet_Calculate()
El Proceso siguiente no lo ejecuta.
'quitar resultados anteriores
Range("F3:K5000").ClearContents
'columna + fila donde empezar/terminar búsqueda
lngColumna = 1
lngFila = 3
lngUltimaFila = Columns(lngColumna). _
  Range("A5000").End(xlUp).Row
'columna + fila donde empezar a pegar resultados
lngPegarColumna = 6
lngPegarFila = 3
'objeto a buscar
strObjetoBuscar = Range("H1").Text
If strObjetoBuscar = "" Then GoTo 99
'minúsculas
strObjetoBuscar = LCase(strObjetoBuscar)
'bucle: realizar búsqueda
For n = lngFila To lngUltimaFila
  'evaluación
  lngResultado = InStr(1, Cells(n, 1), _
     strObjetoBuscar, vbTextCompare)
    'copiar/pegar
    If lngResultado > 0 Then
     Range(Cells(n, 1), Cells(n, 4)).Copy
      Range( _
      Cells(lngPegarFila, lngPegarColumna), _
      Cells(lngPegarFila, lngPegarColumna + 2)) _
        .Select
      ActiveSheet.Paste
    lngPegarFila = lngPegarFila + 1
    End If
Next n
'aparcar
Application.CutCopyMode = False
Range("F3").Select
99:
Dim Cambios As Range
  For Each Cambios In ActiveSheet.Range("L3")
   If Cambios = 0 Then
   MsgBox "No existe Registro"
   Range("H1").Select
   Exit Sub
   End If
   Next
   Sheets("Relacion").Select
   Dim Registros As Range
   For Each Registros In ActiveSheet.Range("H63")
   If Registros = 2 Then
   MsgBox "Ya Existe en la relacion"
   Sheets("Cartera").Select
   Range("H1:K1").ClearContents
   Range("H1").Select
   Exit Sub
   End If
   Next
   Sheets("Cartera").Select
Dim numConsec As Long
Dim strConsec As String
Range("Q1").Select
Selection.NumberFormat = "@"
If IsEmpty(ActiveCell) Then
Range("Q1").Value = "0"
Else
numConsec = Val(Range("Q1").Value) + 1
strConsec = Right("0" & Trim(Str(numConsec)), 1)
Range("Q1").Value = strConsec
End If
Call CopyenRelacion
ActiveWorkbook.Save
End Sub
Sub CopyenRelacion()
'
' CopyenRelacion Macro
'
'
    Sheets("Relacion").Select
    Range("A63:E63").Select
    Selection.Copy
    Range("A61").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("A2:E61").Select
    Range("A61").Activate
    Application.CutCopyMode = False
    ActiveWorkbook.Worksheets("Relacion").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Relacion").Sort.SortFields.Add Key:=Range("A2:A998" _
        ), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Relacion").Sort
        .SetRange Range("A2:E61")
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Sheets("Cartera").Select
    Range("N2").Select
    'ActiveCell.FormulaR1C1 = "OK"
    Range("H1:K1").ClearContents
    Range("H1").Select
    End sub
Saludos y nuevamente Gracias.
Ya veo el problema, como la ejecución de la macro esta vinculada a recalcular, cada vez que recalcula vuelva a regresar a la macro. El tema podría ser añadirle una variable más, de tal forma que si esta variable esta activa, no entre en la ejecución de tu macro, y al terminarla, vuelve a desactivar esa variable. Yo por mi parte intento hacer correr en un fichero limpio esta macro pero me da muchos problemas ya que me faltan nombre datos en celdas, etc...
Si te parece bien posteame tu dirección y yo te envío en email para intercambio de fichero, para ver por donde falla y colocarle la variable en su sitio.
Por otro lado si quieres probar podría ser alago así:
El iniciar el CALCULATE establecemos que si la variable inicio = Empty se ejecta la macro, y cuando entramos en una se tus macros BuscaryAgregar o CopyenRelacion, le ponemos que dicha variable inicio=1.
De todas formas tendría que ver el fichero para ajustarlo bien.
Public Sub Worksheet_Calculate()
   If inicio = Empty Then
   Select Case Range("S1").Value
      Case 1
         BuscayAgrega
      Case 16
         CopyenRelacion
   End Select
   End If
   inicio = Empty
End Sub
Sub BuscayAgrega()
'
' BuscayAgrega Macro
'
' Acceso directo: CTRL+k
'
inicio = 1
Dim CONTRATO As Range
...
[email protected]
Saludos
Ya te he enviado un correo para que me envíes el fichero, pero no recibo contextación, te voy a volver a mandar otro email para que me envíes el fichero.
Pero si no te importa, si das por terminada la pregunta (ya que la seguimos vía email), cierra y valora la ayuda.
(Hay que dejar sitio para otras preguntas)

Añade tu respuesta

Haz clic para o

Más respuestas relacionadas

Macros para buscar cadena de texto

Estoy haciendo una macros para buscar datos de una columna y después pegar toda la fila a otra celda, todo dentro de la misma hoja, quiero modificar el código para que el resultado lo pegue en otra hoja pero no me resulta, por favor si alguien me...
1 respuesta

Macro para inhabilitar una celda

Espero alguien me pueda colaborar... Resulta que estoy haciendo un formato de factura en excel a quien le puse una macro para crear un numero consecutivo que seria el numero de factura el consecutivo funciona pero desearía poder inhabilitar esta...
1 respuesta

Macro para generar un número consecutivo en una misma celda

Quiero saber como hacer una macro para generar un numero consecutivo en una misma celda, que al darle click a un botón me genere el numero que sigue, que comience en 00000 y al dar click al botón me ponga 00001 y así consecutivamente.
1 respuesta

Macro para vincular una celda a un archivo pdf

Utilizo excel 2007, en mi sistema de facturación tengo varias macros, al pulsar un botón me guarda en pdf, imprime, crea siguiente numero de factura y manda la información a una tabla dinámica que lo organiza por numero de albarán, hasta ahí, todo...
1 respuesta

Sacar subotales por año arriba en la hoja

Ayudarme a que arriba aparezcan los totales por año de cada inquilino que vayamos a consultar Gracias Sub Buscar() 'Mod.Por.DAM Application.ScreenUpdating = False Set h1 = Sheets("Estados de cuenta") Set h2 = Sheets("Cartera.") '...
1 respuesta

Macro para copiar filas con condición en otras hojas

Tengo una macro que colorea las filas dependiendo de una condición para que luego otra macro las pase a otras hojas con el mismo nombre de la condición dependiendo del color que tengan, las macros son estas: Sub ColorearFilas() Dim n As Integer Dim...
1 respuesta

Crear una Dll con Vb6.0

Quiero crear una dll con vb y que pueda ser llamada desde otros programas. Tengo el código compilado y la dll creada pero cuando la llamo desde vb u otro programa me da el siguiente error: "no se puede encontrar el punto de entrada de la DLL xxxx"...
1 respuesta

Macro que al hacer enter me ejecute una macro

Necesito una macro que cuando este posicionada en un determinada celda y le de enter me ejecute una y otra macro que cuando le de enter me tire un impubox desde ya a quien me pueda ayudar se lo agradeceré
1 respuesta

Crear cronometro excel 2010

He estado intentando crear una macro para cronometrar con excel y no lo consigo, lo que necesitaría sería el cronometro en si, que cuando le de a un botón comience, con otro botón pare y con otro resetee a "0". También estoy intentando poner una...
1 respuesta

Seleccionar un rango de filas mediante inputbox

Como esta es mi primera pregunta en este foro la pregunta es la siguiente como saben en exel no se pueden seleccionar más de 3 formato condicional pero tengo una macro la cual puede dar formato condicional a más de 3 la macro es la siguiente Rem Ce1...
2 respuestas