Abreviar con macro el código de cada hoja

Me podrían decir si este código que tiene cada página:

Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("A12:D41, H12:H46")) Is Nothing Then
Application.EnableEvents = False
Target.Value = VBA.UCase(Target.Text)
Application.EnableEvents = True
End If
End Sub

Private Sub Worksheet_Activate()
ActiveSheet.Protect Password:="1"
Range("C12").Select
ActiveSheet.ScrollArea = "A1:O46"
End Sub
Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
If Not Application.Intersect(Target, Range("F12:F41")) Is Nothing Then
Cancel = True
Set rMiCelda = Target
Call Crear_PopUp
CommandBars("Clientes").ShowPopup
End If
ActiveSheet.Protect Password:="1"
End Sub

En unas 50 hojas, ¿ Se podría rebajar poniendo Call xxxxxxxx?, y escribirlas en un solo modulo.

Desde que puse tanto código en cada hoja me ha subido el peso del fichero.

1 Respuesta

Respuesta
1

Elimina las macros de todas las hojas y pon lo siguiente en los eventos de Thisworkbook

Private Sub Workbook_SheetActivate(ByVal Sh As Object)
    ActiveSheet.Protect Password:="1"
    Range("C12").Select
    ActiveSheet.ScrollArea = "A1:O46"
End Sub
'
Private Sub Workbook_SheetBeforeRightClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)
    If Not Application.Intersect(Target, Range("F12:F41")) Is Nothing Then
    Cancel = True
    Set rMiCelda = Target
    Call Crear_PopUp
    CommandBars("Clientes").ShowPopup
    End If
    ActiveSheet.Protect Password:="1"
End Sub
'
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
    If Not Intersect(Target, Range("A12:D41, H12:H46")) Is Nothing Then
    Application.EnableEvents = False
    Target.Value = VBA.UCase(Target.Text)
    Application.EnableEvents = True
    End If
End Sub

Saludos.Dante Amor

No olvides valorar la respuesta.

Pero el problema que tengo, es que no son todas las hojas del libro.

Tengo esta macro, en la que secciono todas las hojas en las que uso estas formulas :

Sub Agrupar_hojas_clientes()
' Grabada el 01/01/2015 por Luis
Call TODAS_LAS_Hojas_Desproteger
Sheets("Contado").Select
Sheets(Array("Contado", "Adra Paco", "Balerma Trini", "El Ejido Adelina", "Berja Gador", "Adra Maria", _
"Iznajar Pepa", "Lucena Rafaela", "Lucena Carmen", "Benameji Juan", "Badolatosa Mª Jose", "Casariche Carmen", "Gilena Aurelia", "F. Piedra Antonia", "Humilladero Victoria", "Benameji Sole", _
"Galerias Fernandez", "Fuengirola Paco", "Fuengirola Charo", "Fuengirola Rosalia", "La Cala Antonia", "Marbella Juani", "Marbella Sara", _
"Flores Carmen", "Asuncion Maria", "Asuncion Pepi", "Asuncion Inma", "Asuncion Maria", "Asuncion Pepi", "Asuncion Inma", "Delicias Amparo", "La Paz Cris", "La Paz Paco", "La Luz J. Manuel", "Chapas Virginia Toñi", "P Sur Toñi", "Molinillo Meli", "Union Ramona Gema", _
"Huetor Mª Luisa", "Salar Carmen", "Loja Maribel", "Loja Paqui", "Loja Paqui", "Loja Mª Jose", "Moraleda Paqui", "Loja Pepa Marengo", "V Trabuco Charo", _
"A. Miel Manolo", "A. Miel Conchi Tere", "Torremolinos Paqui", "Torremolinos Fina", "Churriana Eva", "Pima", "Viajante PACO", "Viajante ORTIGOSA")).Select _
Sheets("Contado").Activate
End Sub

En el resto de las hojas no lo necesito.

Gracias Dante, por tu respuesta tan rápida y buena

También podría poner la macro así:

Sub Agrupar_hojas_clientes()
' Grabada el 01/01/2015 por Luis
Call TODAS_LAS_Hojas_Desproteger
Sheets("Contado").Select
Sheets(Array("Contado", "Adra Paco", "Balerma Trini", "El Ejido Adelina", "Berja Gador", "Adra Maria", "Iznajar Pepa", "Lucena Rafaela", "Lucena Carmen", "Benameji Juan", "Badolatosa Mª Jose", "Casariche Carmen", "Gilena Aurelia", "F. Piedra Antonia", "Humilladero Victoria", "Benameji Sole", "Galerias Fernandez", "Fuengirola Paco", "Fuengirola Charo", "Fuengirola Rosalia", "La Cala Antonia", "Marbella Juani", "Marbella Sara", "Flores Carmen", "Asuncion Maria", "Asuncion Pepi", "Asuncion Inma", "Asuncion Maria", "Asuncion Pepi", "Asuncion Inma", "Delicias Amparo", "La Paz Cris", "La Paz Paco", "La Luz J. Manuel", "Chapas Virginia Toñi", "P Sur Toñi", "Molinillo Meli", "Union Ramona Gema", "Huetor Mª Luisa", "Salar Carmen", "Loja Maribel", "Loja Paqui", "Loja Paqui", "Loja Mª Jose", "Moraleda Paqui", "Loja Pepa Marengo", "V Trabuco Charo", "A. Miel Manolo", "A. Miel Conchi Tere", "Torremolinos Paqui", "Torremolinos Fina", "Churriana Eva", "Pima", "Viajante PACO", "Viajante ORTIGOSA")).Select _
Sheets("Contado").Activate
End Sub

Todo seguido.

Un saludo Dante

De todas formas me sale mal:

CommandBars("Clientes").ShowPopup

e manda depurar

Un saludo

Prueba así

Private Sub Workbook_SheetActivate(ByVal Sh As Object)
    Select Case Sh.Name
    Case "Contado", "Adra Paco", "Balerma Trini", "El Ejido Adelina", "Berja Gador", "Adra Maria", "Iznajar Pepa", "Lucena Rafaela", "Lucena Carmen", "Benameji Juan", "Badolatosa Mª Jose", "Casariche Carmen", "Gilena Aurelia", "F. Piedra Antonia", "Humilladero Victoria", "Benameji Sole", "Galerias Fernandez", "Fuengirola Paco", "Fuengirola Charo", "Fuengirola Rosalia", "La Cala Antonia", "Marbella Juani", "Marbella Sara", "Flores Carmen", "Asuncion Maria", "Asuncion Pepi", "Asuncion Inma", "Asuncion Maria", "Asuncion Pepi", "Asuncion Inma", "Delicias Amparo", "La Paz Cris", "La Paz Paco", "La Luz J. Manuel", "Chapas Virginia Toñi", "P Sur Toñi", "Molinillo Meli", "Union Ramona Gema", "Huetor Mª Luisa", "Salar Carmen", "Loja Maribel", "Loja Paqui", "Loja Paqui", "Loja Mª Jose", "Moraleda Paqui", "Loja Pepa Marengo", "V Trabuco Charo", "A. Miel Manolo", "A. Miel Conchi Tere", "Torremolinos Paqui", "Torremolinos Fina", "Churriana Eva", "Pima", "Viajante PACO", "Viajante ORTIGOSA"
        ActiveSheet.Protect Password:="1"
        Range("C12").Select
        ActiveSheet.ScrollArea = "A1:O46"
    End Select
End Sub
'
Private Sub Workbook_SheetBeforeRightClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)
    Select Case Sh.Name
    Case "Contado", "Adra Paco", "Balerma Trini", "El Ejido Adelina", "Berja Gador", "Adra Maria", "Iznajar Pepa", "Lucena Rafaela", "Lucena Carmen", "Benameji Juan", "Badolatosa Mª Jose", "Casariche Carmen", "Gilena Aurelia", "F. Piedra Antonia", "Humilladero Victoria", "Benameji Sole", "Galerias Fernandez", "Fuengirola Paco", "Fuengirola Charo", "Fuengirola Rosalia", "La Cala Antonia", "Marbella Juani", "Marbella Sara", "Flores Carmen", "Asuncion Maria", "Asuncion Pepi", "Asuncion Inma", "Asuncion Maria", "Asuncion Pepi", "Asuncion Inma", "Delicias Amparo", "La Paz Cris", "La Paz Paco", "La Luz J. Manuel", "Chapas Virginia Toñi", "P Sur Toñi", "Molinillo Meli", "Union Ramona Gema", "Huetor Mª Luisa", "Salar Carmen", "Loja Maribel", "Loja Paqui", "Loja Paqui", "Loja Mª Jose", "Moraleda Paqui", "Loja Pepa Marengo", "V Trabuco Charo", "A. Miel Manolo", "A. Miel Conchi Tere", "Torremolinos Paqui", "Torremolinos Fina", "Churriana Eva", "Pima", "Viajante PACO", "Viajante ORTIGOSA"
        If Not Application.Intersect(Target, Range("F12:F41")) Is Nothing Then
        Cancel = True
        Set rMiCelda = Target
        Call Crear_PopUp
        CommandBars("Clientes").ShowPopup
        End If
        ActiveSheet.Protect Password:="1"
    End Select
End Sub
'
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
    Select Case Sh.Name
    Case "Contado", "Adra Paco", "Balerma Trini", "El Ejido Adelina", "Berja Gador", "Adra Maria", "Iznajar Pepa", "Lucena Rafaela", "Lucena Carmen", "Benameji Juan", "Badolatosa Mª Jose", "Casariche Carmen", "Gilena Aurelia", "F. Piedra Antonia", "Humilladero Victoria", "Benameji Sole", "Galerias Fernandez", "Fuengirola Paco", "Fuengirola Charo", "Fuengirola Rosalia", "La Cala Antonia", "Marbella Juani", "Marbella Sara", "Flores Carmen", "Asuncion Maria", "Asuncion Pepi", "Asuncion Inma", "Asuncion Maria", "Asuncion Pepi", "Asuncion Inma", "Delicias Amparo", "La Paz Cris", "La Paz Paco", "La Luz J. Manuel", "Chapas Virginia Toñi", "P Sur Toñi", "Molinillo Meli", "Union Ramona Gema", "Huetor Mª Luisa", "Salar Carmen", "Loja Maribel", "Loja Paqui", "Loja Paqui", "Loja Mª Jose", "Moraleda Paqui", "Loja Pepa Marengo", "V Trabuco Charo", "A. Miel Manolo", "A. Miel Conchi Tere", "Torremolinos Paqui", "Torremolinos Fina", "Churriana Eva", "Pima", "Viajante PACO", "Viajante ORTIGOSA"
        If Not Intersect(Target, Range("A12:D41, H12:H46")) Is Nothing Then
        Application.EnableEvents = False
        Target.Value = VBA.UCase(Target.Text)
        Application.EnableEvents = True
        End If
    End Select
End Sub

Perfecto, menos en :

Private Sub Workbook_SheetBeforeRightClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)

en la línea:

CommandBars("Clientes").ShowPopup

Me sale DEPURAR

Un saludo y gracias Dante, por contestar tan rápido

Esa línea de comando yo no la tengo

De hecho no sé cómo la creaste

En tu contestación de :

Prueba así

En lo que esta en verde, esta en la línea 8.

Yo te puse el encabezamiento, y en la línea que me salia depurar.

Te la pongo entera donde me da el fallo :

Private Sub Workbook_SheetBeforeRightClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)    Select Case Sh.Name    Case "Contado", "Adra Paco", "Balerma Trini", "El Ejido Adelina", "Berja Gador", "Adra Maria", "Iznajar Pepa", "Lucena Rafaela", "Lucena Carmen", "Benameji Juan", "Badolatosa Mª Jose", "Casariche Carmen", "Gilena Aurelia", "F. Piedra Antonia", "Humilladero Victoria", "Benameji Sole", "Galerias Fernandez", "Fuengirola Paco", "Fuengirola Charo", "Fuengirola Rosalia", "La Cala Antonia", "Marbella Juani", "Marbella Sara", "Flores Carmen", "Asuncion Maria", "Asuncion Pepi", "Asuncion Inma", "Asuncion Maria", "Asuncion Pepi", "Asuncion Inma", "Delicias Amparo", "La Paz Cris", "La Paz Paco", "La Luz J. Manuel", "Chapas Virginia Toñi", "P Sur Toñi", "Molinillo Meli", "Union Ramona Gema", "Huetor Mª Luisa", "Salar Carmen", "Loja Maribel", "Loja Paqui", "Loja Paqui", "Loja Mª Jose", "Moraleda Paqui", "Loja Pepa Marengo", "V Trabuco Charo", "A. Miel Manolo", "A. Miel Conchi Tere", "Torremolinos Paqui", "Torremolinos Fina", "Churriana Eva", "Pima", "Viajante PACO", "Viajante ORTIGOSA"        If Not Application.Intersect(Target, Range("F12:F41")) Is Nothing Then        Cancel = True        Set rMiCelda = Target        Call Crear_PopUp        CommandBars("Clientes").ShowPopup        End If        ActiveSheet.Protect Password:="1"    End SelectEnd Sub

esta el fallo en la linea 8 donde dice:

CommandBars("Clientes").ShowPopup

Perdona tantas molestias

En tu contestación de :

Prueba así

En lo que esta en verde, esta en la línea 8.

Yo te puse el encabezamiento, y en la línea que me salia depurar.

Te la pongo entera donde me da el fallo :

'
Private Sub Workbook_SheetBeforeRightClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)
Select Case Sh.Name
Case "Contado", "Adra Paco", "Balerma Trini", "El Ejido Adelina", "Berja Gador", "Adra Maria", "Iznajar Pepa", "Lucena Rafaela", "Lucena Carmen", "Benameji Juan", "Badolatosa Mª Jose", "Casariche Carmen", "Gilena Aurelia", "F. Piedra Antonia", "Humilladero Victoria", "Benameji Sole", "Galerias Fernandez", "Fuengirola Paco", "Fuengirola Charo", "Fuengirola Rosalia", "La Cala Antonia", "Marbella Juani", "Marbella Sara", "Flores Carmen", "Asuncion Maria", "Asuncion Pepi", "Asuncion Inma", "Asuncion Maria", "Asuncion Pepi", "Asuncion Inma", "Delicias Amparo", "La Paz Cris", "La Paz Paco", "La Luz J. Manuel", "Chapas Virginia Toñi", "P Sur Toñi", "Molinillo Meli", "Union Ramona Gema", "Huetor Mª Luisa", "Salar Carmen", "Loja Maribel", "Loja Paqui", "Loja Paqui", "Loja Mª Jose", "Moraleda Paqui", "Loja Pepa Marengo", "V Trabuco Charo", "A. Miel Manolo", "A. Miel Conchi Tere", "Torremolinos Paqui", "Torremolinos Fina", "Churriana Eva", "Pima", "Viajante PACO", "Viajante ORTIGOSA"
If Not Application.Intersect(Target, Range("F12:F41")) Is Nothing Then
Cancel = True
Set rMiCelda = Target
Call Crear_PopUp
CommandBars("Clientes").ShowPopup
End If
ActiveSheet.Protect Password:="1"
End Select
End Sub
'

esta el fallo en la linea 8 donde dice:

CommandBars("Clientes").ShowPopup

No me ha gustado, como me salio en el mensaje anterior.

Perdona tantas molestias

A lo que me refiero que la funcionalidad de esta macro

Call Crear_PopUp

Y la funcionalidad de esto:

CommandBars("Clientes"). ShowPopup

No conozco cómo se originó, yo solamente te regresé las macro con lo que traían, pero esa información la desconozco. Tendrás que revisar la macro Crear_PopUp para ver cómo funciona y cómo crea esto: "CommandBars("Clientes").ShowPopup"

Si quieres que revise esa parte. Valora esta respuesta y crea una nueva pregunta, en la nueva pregunta expones esas macros.

La macro esa esta en un modulo y es :

Const Nombre_PopUp As String = "Clientes"
Public rMiCelda As Range
Sub Crear_PopUp()
Dim cb As CommandBar
Dim sTexto As String
Call DeletePopUp
Application.ErrorCheckingOptions.BackgroundChecking = False
Set cb = CommandBars.Add(Nombre_PopUp, msoBarPopup, False, True)
With cb
sTexto = Worksheets("Listado").Range("F6").Value & " " & Worksheets("Listado").Range("F7").Value
sTexto = StrConv(sTexto, vbProperCase)
With .Controls.Add(Type:=msoControlButton)
.OnAction = "Modificar_Formula_01"
.FaceId = 71
.Caption = sTexto
End With
sTexto = Worksheets("Listado").Range("G6").Value & " " & Worksheets("Listado").Range("G7").Value
sTexto = StrConv(sTexto, vbProperCase)
With .Controls.Add(Type:=msoControlButton)
.OnAction = "Modificar_Formula_02"
.FaceId = 72
.Caption = sTexto
End With
sTexto = Worksheets("Listado").Range("H6").Value & " " & Worksheets("Listado").Range("H7").Value
sTexto = StrConv(sTexto, vbProperCase)
With .Controls.Add(Type:=msoControlButton)
.BeginGroup = True
.OnAction = "Modificar_Formula_03"
.FaceId = 73
.Caption = sTexto
End With
sTexto = Worksheets("Listado").Range("P6").Value & " " & Worksheets("Listado").Range("P7").Value
sTexto = StrConv(sTexto, vbProperCase)
With .Controls.Add(Type:=msoControlButton)
.BeginGroup = True
.OnAction = "Modificar_Formula_06"
.FaceId = 74
.Caption = sTexto
End With
End With
Set cb = Nothing
End Sub
Sub DeletePopUp()
On Error Resume Next
CommandBars(Nombre_PopUp).Delete
End Sub
Sub Modificar_Formula_01()
Call Modificar_Formula(3, rMiCelda)
End Sub
Sub Modificar_Formula_02()
Call Modificar_Formula(4, rMiCelda)
End Sub
Sub Modificar_Formula_03()
Call Modificar_Formula(5, rMiCelda)
End Sub
Sub Modificar_Formula_06()
Call Modificar_Formula(13, rMiCelda)
End Sub
Private Sub Modificar_Formula(ByVal nColumna As Integer, ByVal Target As Range)
ActiveSheet.Unprotect Password:="1"
Target.FormulaR1C1 = _
"=IF(RC3<>"""",VLOOKUP(RC3,tblArticulos," & nColumna & ",FALSE),"""")"
End Sub

Lo que hace es que en cada página de los clientes es que en el rango :

Range("F12:F41")

Me da opción de poner un precio de cuatro opciones

Gracias por las molestias

Puedo dejar esa macro, en cada hoja, y quito las otras dos.

Es una opción, si no se puede solucionar.

Perdona tantas molestias

No es ninguna molestia.

Crea una nueva pregunta en el tema de excel, si gustas la puedes dirigir a Dante Amor, pones la macro.

Añade tu respuesta

Haz clic para o

Más respuestas relacionadas

Agrupando hojas anular la protección individual de cada hoja

En cada hoja del cliente tiene : Private Sub Worksheet_Activate() ActiveSheet.Protect Password:="1" End Sub Y claro no me deja rectificar todas la hojas a la vez. El código de la macro es : Sub Agrupar_hojas_clientes() ' Grabada el 03/09/2014 por...
1 respuesta

Llamar macro con valores de celda

Tengo el siguiente código que ejecuta una macro al cambiar el volor de una celda en un derterminado rango: Private Sub Worksheet_Change(ByVal Target As Range) If Intersect(Target, Range("k5:k300")) Is Nothing Then Exit Sub End If ' If Target >= 0...
1 respuesta

Sumar valor en misma celda

Como lo hago para que al introducir un valor en una celda me sume automáticamente 25. Es decir que al poner 100 en una celda me de esta misma 125
1 respuesta

Validación solo Letras Mayúsculas

Necesito saber si existe alguna forma de validar o de hacer que la gente solo pueda ingresar texto en mayúsculas en una celda. Aguardo respuesta.
1 respuesta

Minusculas a Mayusculas en Excel forma automática

Quisiera que me ayuden para que dentro de un rango se Celdas se active en forma automática una macro que pase las letras de minúsculas a MAYÚSCULAS, sin estar llamando a la macro cada vez que la necesito. En espera de sus respuestas...
2 respuestas

Forzar que se introduzcan solo números en excel

Tengo una hoja de excel en donde en la columna C y DE necesito que unicamente si introduzcan valores numéricos y nada de texto. ¿Cómo podría hacer esto? Otro problema que tengo, es que como le puedo hacer para que no se permita la función Cortar,...
2 respuestas