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
...
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