cómo poner la forma de flecha dentro de las células usando VBA

Question

Estoy trabajando en una macro para generar comparación entre números y tengo la tarea específica de añadir algunas formas cerca del texto de cada célula. Traté de averiguar cómo calcular x, y, ancho, altura con el fin de colocarlos en la celda, pero sin éxito. Pregunté sobre eso en una pregunta anterior y también obtiene una buena respuesta, pero ya que tengo una solicitud específica necesito la manera vba de hacer esto. ¿Alguna sugerencia? Dim s As Shape, sh As Worksheet Set sh = ActiveSheet If arrType =  Up  Then Set s = sh.Shapes.AddShape(msoShapeUpArrow, x, y, width, height) Else Set s = sh.Shapes.AddShape(msoShapeDownArrow, x, y, width, height) End If

codexcrafter · Accepted Answer

Pruebe el siguiente código adaptado, por favor. Sucede que conozco su pregunta anterior sobre este tema, también:

Sub Compare_numbers()
    Dim sh As Worksheet, i As Long, lastRow As Long
    Dim arrA, txt As String
    
    Set sh = ActiveSheet
    lastRow = sh.cells(rows.count, "L").End(xlUp).row
    
    For i = 2 To lastRow
        If sh.cells(i, "L").Value = sh.cells(i, "M").Value Then
            sh.cells(i, "N").Value = "they are equal"
            arrA = isArrow(sh.Range("N" & i), "")
        ElseIf sh.cells(i, "L").Value > sh.cells(i, "M").Value Then
            With sh.cells(i, "N")
                .Value = "L is greater than M    ."
                .EntireColumn.AutoFit
            End With
            arrA = isArrow(sh.Range("N" & i), "Up")
            If arrA(0) = "OK" Then
                If arrA(1) <> "Up" Then
                    insertArrow sh.Range("N" & i), "Up"
                End If
            Else
                insertArrow sh.Range("N" & i), "Up"
            End If
        Else
            With sh.cells(i, "N")
                .Value = "L is greater than M    ." 'Used this solution to Autofit on the larger text...
                .EntireColumn.AutoFit
                .Value = "L is less than M          ."
            End With
            arrA = isArrow(sh.Range("N" & i), "Down")
            If arrA(0) = "OK" Then
                If arrA(1) <> "Down" Then
                    insertArrow sh.Range("N" & i), "Down"
                End If
            Else
                insertArrow sh.Range("N" & i), "Down"
            End If
        End If
    Next i
End Sub

Necesita lo siguiente Sub insertar la flecha apropiada:

Sub insertArrow(rng As Range, arrType As String)
  Dim sh As Worksheet, s As Shape
  Dim leftP As Double, topP As Double, W As Double, H As Double
  
  Set sh = rng.Parent
  W = 8: H = 12 'set the arrow width and height (you can change them)
  leftP = rng.left + rng.width - W - 1  'calculate the horiz position
  topP = rng.top + (rng.height - H) / 2 'calculate the vert position

  If arrType = "Up" Then
    Set s = sh.Shapes.AddShape(msoShapeUpArrow, leftP, topP, W, H)
  Else
    Set s = sh.Shapes.AddShape(msoShapeDownArrow, leftP, topP, W, H)
  End If
  s.Name = s.Name & "-" & rng.Address 'add the cell address to be able
                                      'to bring back the arrows moved by mistake
  s.LockAspectRatio = msoFalse: s.placement = xlMoveAndSize
End Sub

Y el siguiente Function capaz de comprobar si una forma es una flecha y qué tipo:

Function isArrow(rng As Range, typeArr As String) As Variant
  Dim s As Shape, sh As Worksheet, arr
  
  Set sh = rng.Parent 'extract the range sheet where it belongs
  For Each s In sh.Shapes
    If s.TopLeftCell.Address = rng.Address Then 'match the range address with the shape TLCell address
        If left(s.Name, 2) = typeArr Or left(s.Name, 4) = typeArr Then
            isArrow = Array("OK", typeArr): Exit Function
        Else
            If left(s.Name, 2) = "UP" Or left(s.Name, 4) = "Down" Then
                isArrow = Array("OK", IIf(typeArr = "Up", "Down", "Up"))
                s.Delete: Exit Function
            End If
            Exit For
        End If
    End If
  Next
  isArrow = Array("No", "")
  'the function creates an array able to 'tell' if the shape is an arrow and its type
End Function

Desafortunadamente, no hay evento capaz de ser activado por el cambio de tamaños celulares. Pero, prueba el próximo evento, que actúa cuando haga doble clic en una celda. Por favor, copiarlo en el módulo de código de hoja, donde necesita insertar flechas:

Option Explicit

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    Dim lastR As Long, s As Shape, i As Long, addr As String
    
    'bring back the arrows moved by mistakes:
    For Each s In Me.Shapes
        If left(s.Name, 2) = "Up" Or left(s.Name, 4) = "Down" Then
            addr = Split(s.Name, "-")(UBound(Split(s.Name, "-")))
            If addr <> s.TopLeftCell.Address Then
                s.left = Me.Range(addr).left + 10
                s.top = Me.Range(addr).top + 1
            End If
        End If
    Next
    'last row on the column to be processed (N:N):
    lastR = Me.Range("N" & Me.rows.count).End(xlUp).row
    Me.Range("L:N").VerticalAlignment = xlCenter 'to look nicer
    For i = 2 To lastR
        arrangeSh Me.Range("N" & i)
    Next i
End Sub

Sub arrangeSh(rng As Range)
  Dim sh As Shape
  
  For Each sh In rng.Parent.Shapes
    If sh.TopLeftCell.Address = rng.Address Then
        'bring back the row height if is less then the arrow height:
        If rng.height < 12 Then rng.EntireRow.height = 12
        sh.width = 8: sh.height = 12 'reset the arrow dimensions
        'reposition the arrows:
        sh.top = rng.top + (rng.height - sh.height) / 2
        sh.left = rng.left + rng.width - sh.width - 1
        Exit For
    End If
  Next
End Sub

Primero comprobará si la flecha ha sido movida por error y la traerá de vuelta a la célula "madre", luego colocarla centrada, a 1 punto del lado derecho de la célula.

El código del evento se puede colocar en un sub, digamos reArrangeShapes, el evento tendrá una sola línea reArrangeShapes, y este sub puede ser llamado de diferentes eventos de hoja (Calculate, Activar, Desactivar etc.). Hacer su trabajo cuando se desencadenan los eventos en discusión.

Los subs se pueden optimizar utilizando Appliction.ScreenUpdating = True y Application.Calculation = xlCalculationManual al principio seguido Appliction.ScreenUpdating = True y Application.Calculation = xlCalculationAutomatic al final.

Si algo no está claro, por favor, no dude en pedir aclaraciones...

Editado:

Para entender mejor lo que está pasando isArrow función se puede probar utilizando el siguiente sub. Usted debe seleccionar una célula (tener o no una flecha y ejecutar el código:

Sub testIsArrow()
  Debug.Print isArrow(ActiveCell, "Up")(0)
End Sub

¿En qué regresa? Immediate Window (estar en IDE, prensa Ctrl + G)? Usted debe entender que si la célula activa mantiene una flecha no siendo "Up" tipo, la forma será eliminada...

Respondida el Dec 18, 2020 a las 11:28 - por codexcrafter

Gpt · Answer

Para agregar formas de flecha dentro de las celdas usando VBA, puedes utilizar el siguiente código:

vba
Sub AgregarFlechaACelda()
    Dim celda As Range
    Dim flecha As Shape

    Set celda = ThisWorkbook.Sheets("NombreHoja").Range("A1") ' Cambia "NombreHoja" y "A1" por la hoja y celda deseada
    Set flecha = celda.Worksheet.Shapes.AddShape(msoShapeDownArrow, celda.Left, celda.Top, celda.Width, celda.Height)

    With flecha
        .Fill.ForeColor.RGB = RGB(255, 0, 0) ' Cambia el color de la flecha según lo necesites
        .Fill.Transparency = 0 ' Opacidad de la forma (0 a 1)
        .Line.Visible = msoFalse ' Oculta el borde de la forma
    End With
End Sub

En este código, debes especificar la hoja y la celda donde deseas agregar la flecha dentro del rango deseado. Puedes modificar el tipo de flecha (msoShapeDownArrow, msoShapeUpArrow, etc.), el color, la opacidad y otros atributos de la forma según tus necesidades.

Espero que esta información sea de ayuda para tu requerimiento. ¡Déjame saber si tienes alguna otra pregunta!

Respondida el Dec 19, 2020 a las 11:30 - por Gpt

Gemini · Answer

Para colocar una forma de flecha dentro de una celda usando VBA, puedes utilizar el método AddShape del objeto Shapes. Este método toma varios argumentos, incluyendo el tipo de forma, la posición x, la posición y, el ancho y la altura.

Aquí tienes un ejemplo de código VBA que añade una forma de flecha hacia arriba dentro de la celda A1 de la hoja activa:


Sub AddArrowShape()
    Dim s As Shape, sh As Worksheet

    Set sh = ActiveSheet

    Set s = sh.Shapes.AddShape(msoShapeUpArrow, 10, 10, 100, 100)
    s.Placement = xlMoveAndSize
    s.Left = sh.Range("A1").Left + 5
    s.Top = sh.Range("A1").Top + 5
End Sub

En este ejemplo, la forma de flecha se añade a la celda A1 con un desplazamiento de 5 píxeles desde la esquina superior izquierda de la celda. Puedes ajustar los valores de Left y Top para colocar la forma en la posición deseada.

También puedes utilizar el método Placement para especificar cómo se coloca la forma en la celda. El valor predeterminado es xlMove, que mueve la forma sin cambiar su tamaño. Puedes utilizar xlMoveAndSize para mover y cambiar el tamaño de la forma, o xlFreeFloating para colocar la forma independientemente de la celda.

Respondida el Dec 19, 2020 a las 11:33 - por Gemini

cómo poner la forma de flecha dentro de las células usando VBA

3 Respuestas: