cella,effetto interruttore.

[romeos]

ok, ho provveduto così:

Codice: Seleziona tutto

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  Dim CheckArea1 As String
  Dim CheckArea2 As String
  Dim CheckArea3 As String
  Dim bTarget As Boolean
 
  CheckArea1 = "B3:D3, B7:D7,B11:D11,B15:D15,B19:D19,B23:D23,B27:D27,B31:D31,G5:I5,G13:I13,G21:I21,G29:I29,L9:N9,L25:N25"
  CheckArea2 = "A3, A7, A11, A15, A19, A23, A27, A31, F5, F13, F21, F29,K9, K25 "
  CheckArea3 = "E3, E7, E11, E15,E19, E23, E27, E31, J5, J13, J21, J29, O9, O25"
 
 With Target
    If .Cells.Count > 1 Then Exit Sub
    If Not Application.Intersect(Target, Me.Range(CheckArea1)) Is Nothing Then
      If .Interior.ColorIndex = 3 Then
        .Interior.ColorIndex = xlNone
      Else
        .Interior.ColorIndex = 3
      End If
      bTarget = True
    ElseIf Not Application.Intersect(Target, Range(CheckArea2)) Is Nothing Then
     
      If ActiveCell.Interior.ColorIndex = 6 Then
        ActiveCell.Interior.ColorIndex = xlNone
      Else
        ActiveCell.Interior.ColorIndex = 6
      End If
      bTarget = True
    ElseIf Not Application.Intersect(Target, Range(CheckArea3)) Is Nothing Then
     If Target = "V" Then
        Target = ""
      Else
        Target = "V"
      End If
      bTarget = True
    End If
    If bTarget Then
      Application.EnableEvents = False
      Me.Range("G1").Select 'oppure .Offset(0, 1).Select
      Application.EnableEvents = True
    End If
  End With
End Sub

[romeos]

non vorrei abusare della vostra disponibilità, ma chiedo in CheckArea1 = "B3:D3, B7:D7,B11:D11,B15:D15,B19:D19,B23:D23,.....
le celle diventano rosse al clik del mouse, all'interno delle celle vi sono i valori 1,2,3 che rappresentano delle sanzioni questi sono di colore grigio perche tale colore si nota sia con cella bianca che con cella rossa (in questo caso si notano meno), è possibile fare in modo che quando le celle diventano rosse questi valori diventino bianchi?

[ricky53]

Ciao,
SI, nella macro quando imposti il motivo a ROSSO devi impostare il colore del Carattere a BIANCO ... imposta anche lo Stile a "Grassetto".

Per avere le istruzioni attiva il registratore di macro ed imposta il motivo a rosso, il colore del carattere a bianco e lo stile a grassetto.
Fermato il registratore avrai il codice che potrai copiare nella tua macro.

[romeos]

ho sistemato così; sfondo bianco, colore font grigio:sfondo rosso, colore font bianco, sicuramente ci sarà un modo più corretto comunque la macro fa ciò che cercavo,

Codice: Seleziona tutto

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  Dim CheckArea1 As String
  Dim CheckArea2 As String
  Dim CheckArea3 As String
  Dim bTarget As Boolean
 
  CheckArea1 = "B3:D3, B7:D7,B11:D11,B15:D15,B19:D19,B23:D23,B27:D27,B31:D31,G5:I5,G13:I13,G21:I21,G29:I29,L9:N9,L25:N25"
  CheckArea2 = "A3, A7, A11, A15, A19, A23, A27, A31, F5, F13, F21, F29,K9, K25 "
  CheckArea3 = "E3, E7, E11, E15,E19, E23, E27, E31, J5, J13, J21, J29, O9, O25"
 
 With Target
    If .Cells.Count > 1 Then Exit Sub
    If Not Application.Intersect(Target, Me.Range(CheckArea1)) Is Nothing Then
      If .Interior.ColorIndex = 3 Then
        .Interior.ColorIndex = xlNone
      Else
        .Interior.ColorIndex = 3
      End If
       bTarget = True
      If .Font.ColorIndex = 2 Then
        .Font.ColorIndex = 15
      Else
        .Font.ColorIndex = 2
      End If
      bTarget = True

[Anthony47]

Se funziona e' ok come hai fatto, io avrei modificato cosi':

Codice: Seleziona tutto

      If .Interior.ColorIndex = 3 Then
        .Interior.ColorIndex = xlNone
        .Font.ColorIndex = 56
      Else
        .Interior.ColorIndex = 3
        .Font.ColorIndex = 2
      End If
      bTarget = True


Ciao

[romeos]

ok, Anthony47 è sicuramente più corretto il tuo,grazie a tutti.

[Anthony47]

Anthony47 è sicuramente più corretto il tuo

No, al massimo e' corretto quanto il tuo, se anche il mio funziona...

Alla prossima!