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.
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 de Cadipas spain
1
1
Cadipas spain, Aficionado Execel y Macros etc
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)
'----------------
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
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 ?
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.
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
...
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
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)
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)
- Compartir respuesta
- Anónimo
ahora mismo