Excel Colocar nº e aparecer chaveta correspondente, Excel 2003 e Excel 2007

[Bikke]

Boa noite

 

Venho solicitar ajuda para completar o código VBA.

 

Gostaria que, ao se colocar o Nº 3, três vezes seguidos na vertical desde a célula A6 até A24, aparecesse a chaveta correspondente, conforme está na planilha.

 

Já possuo o código VBA para a chaveta 1 e para a 2.

 

Como foi o osvaldo que fez o código VBA, venho aqui solicitar ajuda para a chaveta 3.

 

Obrigado

 

Cumprimentos

 

Código VBA das chavetas 1 e 2

Private Sub Worksheet_Change(ByVal Target As Range)

  Dim s As Shape
  Dim shp       As Shape
  Dim rng       As Range
  Dim OleObj    As OLEObject
  

'''''''''''''' Código VBA das Chavetas ''''''''''
 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 + 27, 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

 

 

Diligencias ao exterior.rar

[Visitante]

Substitua o código atual por este abaixo.

 

' Código das Chavetas
Private Sub Worksheet_Change(ByVal Target As Range)
 Dim cha As Shape, c As String, b 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
    ElseIf Cells(k, 1).Value = 3 And Cells(k + 2, 1).Value = 3 And Cells(k + 4, 1).Value = 3 Then
     c = Cells(x + 1, 1).Address & ":" & Cells(x + 2, 1).Address
     b = Cells(x + 3, 1).Address & ":" & Cells(x + 6, 1).Address: k = k + 4
    Else: GoTo prx
    End If
    Set cha = ActiveSheet.Shapes.AddShape(29, Cells(x, 1).Left + 27, Cells(x + 1, 1).Top, 18, Range(c).Height)  '.Left + 23
     With cha.Line
      .ForeColor.ObjectThemeColor = msoThemeColorText1
      .Weight = 2.5
     End With
    If b <> "" Then
     Set cha = ActiveSheet.Shapes.AddShape(29, Cells(x, 1).Left + 27, Cells(x + 1, 1).Top, 18, Range(b).Height)
     With cha.Line
      .ForeColor.ObjectThemeColor = msoThemeColorText1
      .Weight = 2.5
     End With
    End If
   End If
prx:
  b = ""
  Next k
End Sub

 

[Bikke]

Boa noite osvaldo

 

Maravilha, está na perfeição.

 

Os meus sinceros agradecimentos.

 

Uma boa noite

 

Cumprimentos

 

 

 

[Bikke]

Boa noite osvaldo

 

Peço desculpa de abrir o post de novo, mas gostaria de completar uma última coisa neste projecto.

 

Gostaria de ao se colocar o Nº 4, quatro vezes seguido na vertical, desde a célula A6 até à A24, apareça a chaveta conforme está na planilha.

 

Os meus agradecimentos desde já.

 

O código existente é este:

' Código das Chavetas

 Dim cha As Shape, c As String, b 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
    ElseIf Cells(k, 1).Value = 3 And Cells(k + 2, 1).Value = 3 And Cells(k + 4, 1).Value = 3 Then
     c = Cells(x + 1, 1).Address & ":" & Cells(x + 2, 1).Address
     b = Cells(x + 3, 1).Address & ":" & Cells(x + 6, 1).Address: k = k + 4
    Else: GoTo prx
    End If
    Set cha = ActiveSheet.Shapes.AddShape(29, Cells(x, 1).Left + 27, Cells(x + 1, 1).Top, 18, Range(c).Height)
     With cha.Line
      .ForeColor.ObjectThemeColor = msoThemeColorText1
      .Weight = 2.5
     End With
    If b <> "" Then
     Set cha = ActiveSheet.Shapes.AddShape(29, Cells(x, 1).Left + 27, Cells(x + 1, 1).Top, 18, Range(b).Height)
     With cha.Line
      .ForeColor.ObjectThemeColor = msoThemeColorText1
      .Weight = 2.5
     End With
    End If
   End If

prx:
  b = ""
  Next k
End Sub

Cumprimentos

Diligencias ao exterior.rar

[Visitante]

 

Experimente:

 

' Código das Chavetas
Private Sub Worksheet_Change(ByVal Target As Range)
 Dim cha As Shape, c As String, k As Long, x As Long, m As Long, v 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
     v = 1
    ElseIf Cells(k, 1).Value = 2 And Cells(k + 2, 1).Value = "" And Cells(k + 4, 1).Value = 2 Then
     c = Cells(x + 2, 1).Address & ":" & Cells(x + 5, 1).Address: v = 1
    ElseIf Cells(k, 1).Value = 3 And Cells(k + 2, 1).Value = 3 And Cells(k + 4, 1).Value = 3 Then
     v = 2
    ElseIf Cells(k, 1).Value = 4 And Cells(k + 2, 1).Value = 4 And Cells(k + 4, 1).Value = 4 And Cells(k + 6, 1).Value = 4 Then
     v = 3
    Else: GoTo prx
    End If
     If c = "" Then c = Cells(x + m + 1, 1).Address & ":" & Cells(x + m + 2, 1).Address
     For m = 1 To v
      Set cha = ActiveSheet.Shapes.AddShape(29, Cells(x, 1).Left + 27, Cells(x + 2 * m - 1, 1).Top, 18, Range(c).Height)
       With cha.Line
        .ForeColor.ObjectThemeColor = msoThemeColorText1
        .Weight = 2.5
       End With
     c = Cells(x + 2 * m + 1, 1).Address & ":" & Cells(x + 2 * m + 2, 1).Address
    Next m
    k = k + 2 * v: c = ""
   End If
prx:
  Next k
End Sub

 

[Bikke]

Boa noite osvaldo

 

Simplesmente genial, perfeito.

 

Agora o meu projecto ficou completo.

 

O meu muito obrigado.

 

Continuação de um bom fim de semana.

 

Cumprimentos