Como realizar un desplazamiento uniforme de objetos con Macro
Hola, anexo un archivo con la acción de mover 6 objetos en forma de ruleta a través de una macro, el detalle es que no se como lograr los posicionamientos exactos ya que la posición de una afecta todas las demás.
De antemano les agradezco.
Sub vuelta1()
repetir:
With ActiveSheet.Shapes.Range(Array("logo1"))
.Left = .Left + 2.04
.Top = .Top + 1.1
DoEvents
'limitas el ancho del recorrido horizontal
If .Left > 719 Then End
End With
With ActiveSheet.Shapes.Range(Array("logo2"))
.Left = .Left + 2.03
.Top = .Top - 1.08
DoEvents
'limitas el ancho del recorrido horizontal
If .Left > 544 Then End
End With
With ActiveSheet.Shapes.Range(Array("logo3"))
.Top = .Top - 2.1
DoEvents
'limitas el ancho del recorrido horizontal
If .Top < 111 Then End
End With
With ActiveSheet.Shapes.Range(Array("logo4"))
.Left = .Left - 1.85
.Top = .Top - 1
DoEvents
'limitas el ancho del recorrido horizontal
If .Top < 290 Then End
End With
With ActiveSheet.Shapes.Range(Array("logo5"))
.Left = .Left - 1.87
.Top = .Top + 1
DoEvents
'limitas el ancho del recorrido horizontal
If .Top > 382 Then End
End With
With ActiveSheet.Shapes.Range(Array("logo6"))
.Top = .Top + 2.2
DoEvents
'limitas el ancho del recorrido horizontal
If .Top > 289 Then End
End With
GoTo repetir
End Sub
1 Respuesta
Hola Dante, ya te envié el archivo solicitado.
Te envié el archivo para girar los objetos. No me comentaste si querías que giraran a la derecha o a la izquierda, así que te puse las 2 opciones, solamente tienes que poner en la celda J2 la palabra "si" para que gire a la derecha, de lo contrario gira a la izquierda.
La macro:
Sub girar()
'Por.Dante Amor
topes = Array(18, 110, 289, 382, 289, 110)
izqui = Array(544, 372, 372, 545, 717, 717)
derecha = UCase(Range("J2"))
For i = 1 To 6
ActiveSheet.Shapes("LOGO" & i).Select
ta = ActiveSheet.Shapes("LOGO" & i).Top
la = ActiveSheet.Shapes("LOGO" & i).Left
For j = LBound(topes) To UBound(topes)
If ta = topes(j) And la = izqui(j) Then
If derecha = "SI" Then
If j = 0 Then n = 5 Else n = j - 1
Else
If j = 5 Then n = 0 Else n = j + 1
End If
ActiveSheet.Shapes("LOGO" & i).Top = topes(n)
ActiveSheet.Shapes("LOGO" & i).Left = izqui(n)
End If
Next
Next
Range("O4").Select
End Sub
Hola amigo, esta excelente, lo unico que queria ver es si se pudiera que dichos desplzamientos fueran visualez ya que de esta forma solo desaparecen en una posición y aparecen en otra y en el primer archivo que te envie anexe la rutina deseada pero no consigo que las cordenadas de posicionamiento me dejen las figuras correctamente colocadas.
Te envié el archivo con la macro, en el correo te envié unos comentarios.
Es importante la macro "posicionar_origen", para que en caso de error o por cualquier causa se desacomoden los logos, con esta macro puedas regresar cada logo a su posición original y entonces puedas iniciar nuevamente el movimiento.
También es importante que los logos conserven su nombre de objeto: "LOGO1" al "LOGO6".
Esta es la nueva macro
Sub girar()
'Por.Dante Amor
Dim logo As New Collection
Dim pos As New Collection
On Error GoTo reinicio
If Range("O1") = " " Then Exit Sub
With ActiveSheet
Range("O1") = " "
For i = 1 To 6
t1 = .Shapes("LOGO" & i).Top
l1 = .Shapes("LOGO" & i).Left
logo.Add "LOGO" & i
Select Case t1 & l1
Case "20552": pos.Add 1
Case "110372": pos.Add 2
Case "290372": pos.Add 3
Case "380552": pos.Add 4
Case "290732": pos.Add 5
Case "110732": pos.Add 6
End Select
Next
For i = 1 To 45
For j = 1 To 6
Select Case pos(j)
Case 1
.Shapes(logo(j)).Top = .Shapes(logo(j)).Top + 2
.Shapes(logo(j)).Left = .Shapes(logo(j)).Left + 4
Case 2
.Shapes(logo(j)).Top = .Shapes(logo(j)).Top - 2
.Shapes(logo(j)).Left = .Shapes(logo(j)).Left + 4
Case 3
.Shapes(logo(j)).Top = .Shapes(logo(j)).Top - 4
Case 4
.Shapes(logo(j)).Top = .Shapes(logo(j)).Top - 2
.Shapes(logo(j)).Left = .Shapes(logo(j)).Left - 4
Case 5
.Shapes(logo(j)).Top = .Shapes(logo(j)).Top + 2
.Shapes(logo(j)).Left = .Shapes(logo(j)).Left - 4
Case 6
.Shapes(logo(j)).Top = .Shapes(logo(j)).Top + 4
End Select
DoEvents
Next
'DoEvents
Next
End With
Set logo = Nothing
Set pos = Nothing
Range("O1") = ""
End
reinicio:
MsgBox "Ocurrió un error los Logos regresarán a su posición original", vbInformation, _
"Error: " & Err.Number & ", " & Err.Description
Set logo = Nothing
Set pos = Nothing
Range("O1") = ""
posicionar_origen
End
End Sub
Sub posicionar_origen()
'Por.Dante Amor
logos = Array("LOGO1", "LOGO2", "LOGO3", "LOGO4", "LOGO5", "LOGO6")
topes = Array(20, 110, 290, 380, 290, 110)
izqui = Array(552, 372, 372, 552, 732, 732)
For i = LBound(logos) To UBound(logos)
ActiveSheet.Shapes(logos(i)).Top = topes(i)
ActiveSheet.Shapes(logos(i)).Left = izqui(i)
Next
End SubSaludos.Dante Amor
Recuerda valorar la respuesta.
