............ Foro Excel
Si no lo has hecho aún: REGISTRATE!!!

Tamaño de un rectangulo de acuerdo a una celda

Ver el tema anterior Ver el tema siguiente Ir abajo

Tamaño de un rectangulo de acuerdo a una celda

Mensaje por JONATHAN el Sáb Mayo 10, 2008 1:28 am

Hola, te molesto nuevamente con una pregunta
en un foro un compañero me paso un codigo el cual he modificado y muestro enseguida:

Sub rectangulo4()
For Each Changue In Cells(1, 2)
If Range("A2").Value = 1 Then
izquierda = Range("B2").Left
arriba = Range("B2").Top
derecha = Range("C2").Left - izquierda
abajo = Range("B3").Top - arriba
ActiveSheet.Shapes.AddShape(msoShapeRectangle, izquierda, arriba, derecha, abajo).Select
Selection.ShapeRange.Line.Weight = 0.75
Selection.ShapeRange.Line.DashStyle = msoLineSolid
Selection.ShapeRange.Line.Style = msoLineSingle
Selection.ShapeRange.Line.Transparency = 0#
Selection.ShapeRange.Line.Visible = msoTrue
Selection.ShapeRange.Line.ForeColor.SchemeColor = 64
Selection.ShapeRange.Line.BackColor.RGB = RGB(255, 255, 255)
Selection.ShapeRange.Fill.Visible = msoTrue
Selection.ShapeRange.Fill.ForeColor.SchemeColor = 9
Selection.ShapeRange.Fill.BackColor.RGB = RGB(0, 0, 0)
Selection.ShapeRange.Fill.Transparency = 0#
Selection.ShapeRange.Fill.TwoColorGradient msoGradientHorizontal, 3
Else
MsgBox "Falta definir parametros"
End If
Next
End Sub

Lo que hace esta macro es simplemente verificar si en la celda A2 =1 entonces crea un rectangulo que cubra toda la celda B2, sin importar el ancho de esta, no se sale de esos limites, lo que yo intento ahora es que este rango (izquierda, derecha) sea dinamico de acuerdo a lo que yo escriba en A2, como la de indirecto, si yo escribo en A2 F5, entonces que me ponga el rectangulo en f5 y asi segun yo le escriba

¿alguien sabe como hacerlo?

Desde ya muchas gracias

Atte. Jonathan

JONATHAN

Cantidad de envíos : 24
Fecha de inscripción : 28/04/2008

Volver arriba Ir abajo

Re: Tamaño de un rectangulo de acuerdo a una celda

Mensaje por ioyama el Lun Mayo 12, 2008 3:14 am

Hola Jonathan

A partir del código que presentabas, prueba con
Código:

Sub rectangulo4()
If Range("A2") <> "" Then
    celda = Range("A2")
    ult = Len(celda)
    For i = 1 To ult
        num = Val(Mid(celda, i, 1))
        If num > 0 Then Exit For
    Next i
    letcelda = Left(celda, i - 1)
    numcelda = Right(celda, Len(celda) - Len(letcelda)) * 1
    col = Columns("A:" & letcelda).Count
    izquierda = Range(celda).Left
    arriba = Range(celda).Top
    derecha = Cells(numcelda, col + 1).Left - izquierda
    abajo = Range(letcelda & numcelda + 1).Top - arriba
    ActiveSheet.Shapes.AddShape(msoShapeRectangle, izquierda, arriba, derecha, abajo).Select
    Selection.ShapeRange.Line.Weight = 0.75
    Selection.ShapeRange.Line.DashStyle = msoLineSolid
    Selection.ShapeRange.Line.Style = msoLineSingle
    Selection.ShapeRange.Line.Transparency = 0#
    Selection.ShapeRange.Line.Visible = msoTrue
    Selection.ShapeRange.Line.ForeColor.SchemeColor = 64
    Selection.ShapeRange.Line.BackColor.RGB = RGB(255, 255, 255)
    Selection.ShapeRange.Fill.Visible = msoTrue
    Selection.ShapeRange.Fill.ForeColor.SchemeColor = 9
    Selection.ShapeRange.Fill.BackColor.RGB = RGB(0, 0, 0)
    Selection.ShapeRange.Fill.Transparency = 0#
    Selection.ShapeRange.Fill.TwoColorGradient msoGradientHorizontal, 3
Else
    MsgBox "Falta definir parametros"
End If
End Sub

Un saludo desde Vitoria

ioyama
Moderador
Moderador

Masculino Cantidad de envíos : 128
Edad : 54
Ciudad - Pais : Vitoria (España)
Fecha de inscripción : 03/03/2008

Volver arriba Ir abajo

Ver el tema anterior Ver el tema siguiente Volver arriba


 
Permisos de este foro:
No puedes responder a temas en este foro.