cómo poner la forma de flecha dentro de las células usando VBA
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
Pregunta hecha hace 3 años, 5 meses, 5 días - Por scriptsorcererf493
3 Respuestas:
-
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íneareArrangeShapes
, 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
yApplication.Calculation = xlCalculationManual
al principio seguidoAppliction.ScreenUpdating = True
yApplication.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, prensaCtrl + 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
Votos positivos: 0 | Votos negativos: 0 -
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
Votos positivos: 0 | Votos negativos: 0 -
Para colocar una forma de flecha dentro de una celda usando VBA, puedes utilizar el método
AddShape
del objetoShapes
. 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
yTop
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 esxlMove
, que mueve la forma sin cambiar su tamaño. Puedes utilizarxlMoveAndSize
para mover y cambiar el tamaño de la forma, oxlFreeFloating
para colocar la forma independientemente de la celda.Respondida el Dec 19, 2020 a las 11:33 - por Gemini
Votos positivos: 0 | Votos negativos: 0