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

Respuesta
1

No pusiste el archivo, podrías enviarme tu archivo, en una hoja me pones tal cual tienes los objetos y en otra hoja me pones los mismos objetos pero desplazados, simulando el movimiento que deseas.

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 Sub

Saludos.Dante Amor

Recuerda valorar la respuesta.

Añade tu respuesta

Haz clic para o

Más respuestas relacionadas

Llamadas telefonicas con mi programa en VB6

Estoy tranajando en un pequeña agenda telefonica junto con su base de datos, el asunto es que desearia que tambien sea capaz de efectuar llamadas. ¿Cómo puedo hacer para que pueda realizar las llamadas?
1 respuesta

Macro eliminar imágenes

He hecho una macro que coge de una carpeta las imágenes, según ciertos paramtros puestos en celdad de mi hoja, e inserta las imágenes. Ahora quería hacer una que me eliminara dichas imágenes( una función limpia). Lo he intentado con la grabadora de...
1 respuesta

Macros para mostrar varias imágenes según valor de celda

Tengo la siguiente macro que me arroja la fotografía de un empleado el teclear su número de empleado en determinada celda. Me gustaría que fueran varias celdas que arrojaran varias imágenes según en número de empleado en la misma hoja. ¿Cómo puedo...
2 respuestas

Macro para borrar muchas imágenes en Excel 2010

Como manejo una hoja con muchas imágenes hice una macro para borrarlas cuando necesitara ordenar o copia y luego las ponía nuevamente, dependiendo del equipo donde trabajara alguna vez me salia un error por falta de memoria, asi que recompuse la...
1 respuesta

Redimensionar matriz bidimensional

Disculpa la molestia pero resulta que estoy realizando una guía para almacenar personas con dirección, nombre, apellido y teléfono y uso una matriz bidireccional dinámica ya que esa es la consigna. Y cuando ya tengo una persona cargada no puedo...
1 respuesta

Macro para enviar correos y alterar el formato del cuerpo del correo

Ojala me puedan ayudar, tengo una rutina para envío de correos, y jala perfecto solo que ahora me han pedido darle formato al mail algunas palabras en negritas y no se como hacer esa modificación ya que el texto esta en la rutina jala las fechas de...
1 respuesta

Macro para eliminar imagen (con nombre referido a dos celdas)

Después de hacer varias búsquedas en internet encontré esta macro que me funciona perfectamente para insertar una imagen en una celda, el nombre de esta imagen se genera a partir del valor de dos celdas: Sub Insertarimagen() tope = Range("C10").Top...
1 respuesta

Eliminar múltiples imágenes de Hoja de calculo

¿Quisiera saber como puedo seleccionar toda la información de una hoja de calculo y eliminarla de una vez? Me explico, la hoja tiene celdas con texto y celdas con imágenes. Si clickeo sobre el espacio que hay entre la Columna A y la celda 1, se...
1 respuesta

Cambiar color de autoforma con una condicional

Ayudame con esta pregunta: como seria el algoritmo de una macro para que una autoforma cambie de color con una condicional, por ejemplo la condicional seria si la celda A1 es menor a la celda A2 entonces la autoforma cambie a color rojo, le agradezco...
1 respuesta

Imágenes en Excel

Quiero hacer una macro que borre unas imágenes que coloqué me diante otra macro, es decir yo realicé una macro que coloca las imágenes pero no he podido realizar la macro que las borre y entonces me toca borrarlas manualmente.
1 respuesta