Excel Ao colocar um numero numa célula, aparece chaveta apanhar 2 células, Excel 2007

[Bikke]

Boa noite

 

Venho solicitar ajuda no seguinte

 

A usar em Excel 2003 e Excel 2007 em Português de Portugal

 

Tenho uma planilha que, ao se colocar o 1 na célula A6 e A8, aparece automáticamente uma chaveta preta a apanhar as duas células C6 e C8

O numero pode ser colocado desde a célula A6 à A24, porque posso querer o mesmo efeito em A18 e A20, ou em outras células, é conforme o planeado.

 

Se colocar o 2 na célula A10 e A14, aparece automáticamente uma chaveta preta a apanhar as duas células C10 e C14

O numero pode ser colocado desde a célula A6 à A24, porque posso querer o mesmo efeito em outras células, é conforme o planeado.

 

Segue planilha para verem e perceberem o que pretendo.

 

Na planilha já vai com outra opção do x em N6 a N24, feito pelo Mestre osvaldomp na altura que foi solicitado.

 

Obrigado pela atenção

 

Bom fim de semana

 

Cumps

Diligencias._V2.xls

[Visitante]

21 horas atrás, Bikke disse:

Tenho uma planilha que, ao se colocar o 1 na célula A6 e A8, aparece automáticamente uma chaveta preta a apanhar as duas células C6 e C8

 

Olá, Cumps.

Atualmente na sua planilha as chavetas não aparecem automaticamente. Então devemos entender que é esse recurso que você deseja ter na planilha ?

[Bikke]

Boa Noite osvaldomp

 

Sim, é através desse recurso que eu pretendo, ou outro que faça o mesmo efeito.

 

Neste momento falei que, através de números inserido o 1 apanha duas células distintas, e se colocar o 2 apanha duas também, mas com uma de intervalo ( célula ), e isso ao longo da coluna.

 

Mas, se houver outro critério que faça o mesmo, excelente.

 

Cumps

[Visitante]

Primeiramente instale uma cópia do primeiro código abaixo no lugar do existente e faça os testes. Ele irá atuar somente na coluna A, conforme o que você solicitou.

Se o resultado for conforme o desejado então instale uma cópia do segundo código abaixo no lugar. O segundo código é a união do código existente com o primeiro abaixo, então ele irá atuar nas colunas A e N.

Private Sub Worksheet_Change(ByVal Target As Range)
 Dim cha As Shape, c As String, k As Long, x As Long
  If Intersect([A6:A24], Target) Is Nothing Then Exit Sub
  For Each cha In ActiveSheet.Shapes
   If Not Intersect(cha.TopLeftCell, Columns(2)) Is Nothing Then cha.Delete
  Next cha
  For k = 6 To 22 Step 2
   x = k
   If Cells(k, 1).Value <> "" Then
    If Cells(k, 1).Value = 1 And Cells(k + 2, 1).Value = 1 Then
     c = Cells(x + 1, 1).Address & ":" & Cells(x + 2, 1).Address: k = k + 2
    ElseIf Cells(k, 1).Value = 2 And Cells(k + 2, 1).Value = "" And Cells(k + 4, 1).Value = 2 Then
     c = Cells(x + 1, 1).Address & ":" & Cells(x + 4, 1).Address: k = k + 4
    Else: GoTo prx
    End If
    Set cha = ActiveSheet.Shapes.AddShape(29, Cells(x, 1).Left + 23, Cells(x + 1, 1).Top, 18, Range(c).Height)
     With cha.Line
      .ForeColor.ObjectThemeColor = msoThemeColorText1
      .Weight = 2.5
     End With
   End If
prx:
  Next k
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
 Dim s As Shape, shp As Shape, rng As Range, OleObj As OLEObject
 Dim cha As Shape, c As String, k As Long, x As Long

  If Not Intersect([N6:N24], Target) Is Nothing Then
'   ActiveSheet.Unprotect 321   '* altere a senha AQUI
   Target.Offset(, -2).Value = ""
   For Each s In ActiveSheet.Shapes
    If s.TopLeftCell.Row = Target.Row + 1 Then
     s.Delete: Exit For
    End If
   Next s
   If Target(1, 1).Value = "x" Then
    Set s = Me.Shapes.AddLine(Cells(Target.Row + 1, 3).Left + 6, Cells(Target.Row + 1, 2).Top, _
     Cells(Target.Row + 1, 12).Left + 2, Cells(Target.Row + 1, 12).Top)
      s.Line.ForeColor.RGB = RGB(255, 0, 0)
      s.Line.Weight = 2.5
     With Target.Offset(, -2)
      .Value = "S/Efeito"
      .Font.Bold = True
      .Font.ColorIndex = 3
     End With
   End If
'    ActiveSheet.Protect 321 '* altere a senha AQUI
  End If
    
  If Intersect([A6:A24], Target) Is Nothing Then Exit Sub
   For Each cha In ActiveSheet.Shapes
    If Not Intersect(cha.TopLeftCell, Columns(2)) Is Nothing Then cha.Delete
   Next cha
   For k = 6 To 22 Step 2
    x = k
    If Cells(k, 1).Value <> "" Then
     If Cells(k, 1).Value = 1 And Cells(k + 2, 1).Value = 1 Then
      c = Cells(x + 1, 1).Address & ":" & Cells(x + 2, 1).Address: k = k + 2
     ElseIf Cells(k, 1).Value = 2 And Cells(k + 2, 1).Value = "" And Cells(k + 4, 1).Value = 2 Then
      c = Cells(x + 1, 1).Address & ":" & Cells(x + 4, 1).Address: k = k + 4
     Else: GoTo prx
     End If
     Set cha = ActiveSheet.Shapes.AddShape(29, Cells(x, 1).Left + 23, Cells(x + 1, 1).Top, 18, Range(c).Height)
      With cha.Line
       .ForeColor.ObjectThemeColor = msoThemeColorText1
       .Weight = 2.5
      End With
    End If
prx:
   Next k
End Sub

 

[Bikke]

Boa tarde osvaldomp

 

Copiei e colei o primeiro código, testei, funcionou direito, copiei e colei o segundo, começou a dar erros.

 

If Not Intersect(cha.TopLeftCell, Columns(2)) Is Nothing Then cha.Delete

 

Fica com a cor amarela o que coloquei em cima e está com a cor vermelha

 

Outra coisa que acontece é: se eu colocar a chaveta e depois quiser que colocar o x para que eu saiba que ficou sem efeito, aparece a linha vermelha e a dizer sem efeito, mas, a chaveta desaparece...

 

 

[Visitante]

Para corrigir o segundo erro substitua esta linha

If s.TopLeftCell.Row = Target.Row + 1 Then

por esta

If s.TopLeftCell.Row = Target.Row + 1 And Not Intersect(s.TopLeftCell, Columns(3)) Is Nothing Then

 

O primeiro erro eu não consegui reproduzir aqui. Teste novamente após a alteração acima.

[Bikke]

Osvaldomp

 

Coloquei o código que deste, e já funciona direitinho, mas, quando vou apagar o 1 ou o 2, aparece a mensagem que está na imagem.

 

 

[Visitante]

Aqui não ocorre esse erro.

 

No primeiro código existe uma linha de comando igual a essa que apresenta o erro no segundo código. Ao testar somente o primeiro código esse erro também ocorre?

 

Você pode tirar um print da região da planilha que mostra os números e as chavetas e indicar qual a célula que ao ser limpada apresenta o erro ?

[Bikke]

Não entendo o que se está a passar.

 

Agora clico para apagar, os números desaparecem, ,mas as chavetas continuam lá.

 

Basta colocar o numero na primeira e apaga tudo.

 

Grrrrrrrr

[Visitante]

O arquivo anexado tem duas planilhas, uma com o primeiro código e a outra com o segundo. Não apresenta erro aqui. Faça os testes.

Cumps Diligencias._V2.zip

[Bikke]

Já sei porque é que dá aquele erro

 

A planilha é para estar protegida, mas, tem que estar activado o Editar objectos, conforme mostra na imagem.

 

Assim, isto já está resolvido.

 

Obrigado por tudo osvaldomp.

 

Sem ti, não conseguiria resolver este meu projecto.

 

Muito obrigado

 

Bom semana de trabalho.

 

Cumps