Buenas chicos.

Tengo una hoja excel con unas 400 celdas (combinadas de diferentes tamaños) que simulan una excavación arqueológica.

Cuando en una de esas celdas pongo un "1" se ponen de un color, con un "2" de otro, y asi hasta el "5".

Hay celdas que solo pueden ir con el número "1" y otras solo con el resto "2-3-4-5". La idea es conseguir que en las celdas que SOLO pueden tener un "1" de alguna forma se impida meter otro número o si se hace que se borre.

Para las celdas que solo admiten el "1" he usado este código que avisa que no se puede poner ese número y borra el contenido.

Private Sub Worksheet_Change(ByVal Target As Range)

    If Range("BH4") > "1" Then

        MsgBox "Esta excavación no permite este código. Insertar 1"

        Range("BH4:BH5").ClearContents

    ElseIf Range("BJ4") > "1" Then

        MsgBox "Esta excavación no permite este código"

        Range("BJ4:BJ5").ClearContents

    ElseIf Range("BL4") > "1" Then

        MsgBox "Esta excavación no permite este código"

        Range("BL4:BL5").ClearContents

End If

End Sub

Y para las celdas solo admiten el "2-3-4-5" este otro código.

    ElseIf Range("BH6") = "1" Then

        MsgBox "Esta excavación no permite este código. Inserta 2, 3, 4 o 5"

        Range("BH6:bH10").ClearContents

    ElseIf Range("BJ6") = "1" Then

        MsgBox "Esta excavación no permite este código. Inserta 2, 3, 4 o 5"

        Range("BJ6:bJ10").ClearContents

Alguna otra solución? ya que hacer esto por cada celda es una currada.

Las celdas combinadas donde solo puede ir el "1" son de dos celdas A1:A2 por ejemplo y las otras son de 5 celdas A3:A7.

Gracias.

¿Y usar la validación de datos? Seleccionas todas las celdas, vas a validación de datos e indicas los valores permitidos. Con hacerlo una vez para cada tipo de validación es suficiente, y sin una línea de código:

- https://support.office.com/es-es/article/Aplicar-la-validación-de-datos-a-celdas-29fecbcc-d1b9-42c1-9d76-eff3ce5f7249

Mira si el color es rojo (o el color que sea cuando es nivel 1) y si lo es, pones "a pelo" el 1

Para hacer esto en la hoja  (NO en un modulo) pon esto:

Otra alternativa es utilizar un código similar al siguiente:

Espero que ayude a resolver la duda

Un saludo a todos

Otra opción.

Supongo que también sería un problema que a un rango 3 (ya establecido) alguien (por error) lo cambie a rango 5, con el consiguiente cambio de formato. Para evitar esto yo  «juego» con el color de la fuente y con el color del fondo:

 ·  Fuente 1 = RGB(1,1,1)

 ·  Fuente 2 = RGB(2,2,2)

 ·  Fuente 3 = RGB(3,3,3)

 ·  Fuente 4 = RGB(4,4,4)

 ·  Fuente 5 = RGB(5,5,5) 

 ·  AC1:AG1  =   65793, 131586, 197379, 263172 y 328965  (son los tonos de fuente).

Los cinco son tonos de negro que (a nivel humano) no se diferencian, mediante el tono de fuente (el código) «impide» que se alteren  los valores.

Con este código (en un módulo ordinario) obtienes los rangos de AA1:AA22, ...

Sub Macro2()

  Dim f&

  With Range("AA1:AA2")

    .MergeCells = True

    .Font.color = RGB(1, 1, 1)

    Range("AA1").Value = 1

  End With

    For f = 3 To 18 Step 5

    With Cells(f, "AA").Resize(5)

      .MergeCells = True

      .Font.color = RGB((f + 7) / 5, (f + 7) / 5, (f + 7) / 5)

      .HorizontalAlignment = xlCenter

      .VerticalAlignment = xlCenter

      Cells(f, "AA").Value = (f + 7) / 5

    End With

  Next f

End Sub

...  con sus correspondientes colores de fuente. Aplícale manualmente los colores de relleno que prefieras.

 · Cuando necesites  (por ejemplo) un rango 4, selecciona AA13:AA17, das a copiar y pegas en destino (B13:B17).

 ·  Si cambias el color de uno de los rangos origen, en destino permanecen sin cambio hasta que re-escribas su valor, solo aceptará el que le pertenece por color de fuente.

En el módulo de la hoja:

Private Sub Worksheet_Change(ByVal Target As Range)

  Dim i#, fuente$

  On Error Resume Next

  fuente = Target.Font.color

  i = WorksheetFunction.Match(Target.Font.color, Range("AC1:AG1"))

  Application.EnableEvents = False

  Select Case i

    Case 1 To 5 ' fuente con tonos negros especiales.

      Target.Value = i

      Target.Interior.color = Range("AA1").Offset(i * 5 - 5).Interior.color

  End Select

  Application.EnableEvents = True

End Sub

Aquí un enlace con http://www.achinet.mvp-access.es/Excel/Ayudas/hakamin.rar" rel="nofollow - el ejemplo .