macro con autoformas

26/01/2006 - 10:41 por Carlos | Informe spam
Hola a todos
Tengo en una hoja excel una serie de rectángulos (autoformas) de distintas
medidas. Tengo como condición que todos los rectángulos estén adosados como
si fuesen casitas. Lo que quiero es poder arrastrar una "casita" y que al
soltarla en medio de otras dos se reorganicen de forma que en la nueva
distribución la "casita" que he movido aparezca en su nueva posición (con la
condición de que todas las "casitas" estén adosadas, no superpuestas).
Alguien me puede dedir como hacer esto?
Un saludo y gracias

Carlos
 

Leer las respuestas

#1 Héctor Miguel
27/01/2006 - 09:35 | Informe spam
hola, Carlos !

Tengo en una hoja excel una serie de rectangulos (autoformas) de distintas medidas.
Tengo como condicion que todos los rectangulos esten adosados como si fuesen casitas.
Lo que quiero es poder arrastrar una "casita" y que al soltarla en medio de otras dos se reorganicen
de forma que en la nueva distribucion la "casita" que he movido aparezca en su nueva posicion
(con la condicion de que todas las "casitas" esten adosadas, no superpuestas)...



1) [hasta donde se]... NO existe un evento que 'detecte' cuando el usuario cambia de posicion las figuras :(
[en todo caso]... 'tendrias que'... ejecutar una macro que se encargue de 'revisar' [y re-distribuir] las figuras ;)

2) te paso una macro de ejemplo a final con los siguientes 'supuestos'...
a) TODAS las figuras [rectangulos] se van a ajustar [en su posicion superior] al '.Top' de la fila 4 -> Range("a4")
b) la figura que 'quede' mas 'a la izquierda'... sera la figura 'que mande' la posicion izquierda -> inicial -?-
c) solo 'espero' que no tengas diferentes 'gruesos' de lineas en los 'laterales' de los rectangulos :))

si cualquier duda [o informacion adicional]... comentas ?
saludos,
hector.

Sub Re_Ordenar_Casitas()
Application.ScreenUpdating = False
Dim c As Shape, cNum As Byte, n As Byte, cTop As Single, _
cLeft, cName, Tmp, n1 As Byte, n2 As Byte
cTop = Range("a4").Top
For Each c In ActiveSheet.Shapes
If c.AutoShapeType = msoShapeRectangle Then c.Select False
Next: cNum = Selection.Count: If cNum = 0 Then Exit Sub
ReDim cLeft(cNum): ReDim cName(cNum)
For n = 1 To cNum
With Selection.Item(n): cLeft(n) = .Left: cName(n) = .Name: End With: Next
ActiveCell.Select
For n1 = 1 To cNum - 1
For n2 = n1 + 1 To cNum
If cLeft(n1) > cLeft(n2) Then
Tmp = cLeft(n2): cLeft(n2) = cLeft(n1): cLeft(n1) = Tmp
Tmp = cName(n2): cName(n2) = cName(n1): cName(n1) = Tmp
End If: Next: Next
For n = 2 To cNum - 1
With ActiveSheet.Shapes(cName(n)): .Top = cTop
.Left = cLeft(n - 1) + ActiveSheet.Shapes(cName(n - 1)).Width: cLeft(n) = .Left
End With: Next
With ActiveSheet.Shapes(cName(cNum)): .Top = cTop
.Left = cLeft(cNum - 1) + ActiveSheet.Shapes(cName(cNum - 1)).Width: End With
Erase cLeft: Erase cName
End Sub

Preguntas similares