allineare pulsanti in una cella

[raimea]

ciao

sempre in merito alla gestione di > oggetti in una cella
dopo aver scopeto che possono essere cancellati con vba
mi vien da chiedere:

e' possibile allineare l'oggetto al centro della cella con vba ?

in fgl generale
col C da C8:C
ci sono dei quadratini ai quali associo un colleg. ipertest.
vorrei riuscire , se possibile, a metterli al centro della relativa cella.

vi allego il file

https://www.dropbox.com/scl/fi/if5o7nloys1qq67rwkp0x/allinea-pulsanti.xlsm?rlkey=b9t7j4i0x5jue0aobz7jtynn9&dl=0


ciao

[Anthony47]

Derivato dal codice dell’attuale Sub RemPulsanti:

Codice: Seleziona tutto

Sub CentraPulsanti()
Dim Shp As Shape
'
For Each Shp In ActiveSheet.Shapes
'    Debug.Print Shp.Type, Shp.Name, Shp.TopLeftCell.Address(0, 0)
    If Shp.Type = msoPicture Then
        If Shp.TopLeftCell.Column = 3 And Shp.TopLeftCell.Row > 8 Then                         'vedi nota**
            Shp.Top = Shp.TopLeftCell.Top + (Shp.TopLeftCell.Height - Shp.Height) / 2
            Shp.Left = Shp.TopLeftCell.Left + (Shp.TopLeftCell.Width - Shp.Width) / 2
        End If
    End If
Next Shp
End Sub


** forse deve essere If Shp.TopLeftCell.Column = 3 And Shp.TopLeftCell.Row >= 8?

[raimea]

ciao
e' tutto ok

grazie mille

ciao

[raimea]

ciao
sempre in merito agli oggetti, nelle celle di fgl generale

ora posso: cancellarli e allinearli.

chiedo

sarebbe possibile copiare il 1mo oggetto in cella C8
e incollarlo nelle successive 100 celle da C9 ?

allego il file

https://www.dropbox.com/scl/fi/ydbvf062ffkk03aooew2t/incolla-oggetti.xlsm?rlkey=dy8qlp8kgv3q4gjkfhkaxepb6&dl=0

ciao

[Anthony47]

Modifica la tua Sub CentraPulsant come segue:

Codice: Seleziona tutto

Sub DuplicaEtCentraPulsanti()
Dim Shp As Shape
'----------------
' luglio 23 da pc-facile Anthony
' serve a duplicare e allineare i pulsantini in col C al centro delle celle
' http://www.pc-facile.com/forum/viewtopic.php?f=26&t=113041&p=664639&sid=511c36e58a902e069f48ca91d1fbed38#p664639
'-----------------------
Dim RemArea As String, taShp As Shape, myC As Range
RemArea = "C9:C100"
'
'Rimuovi Shapes dalle celle di destinazione:
For Each Shp In ActiveSheet.Shapes
    If Shp.Type = msoPicture Then
        If Not Application.Intersect(Range(RemArea), Shp.TopLeftCell) Is Nothing Then
            Shp.Delete
        Else
            If Shp.TopLeftCell.Address = "$C$8" Then
                Set taShp = Shp
            End If
        End If
    End If
Next Shp
'Copia e aggiungi:
taShp.Copy
DoEvents
For Each myC In Range(RemArea)
    DoEvents
    myC.PasteSpecial xlPasteAll
Next myC
'Centra nella cella
For Each Shp In ActiveSheet.Shapes
'    Debug.Print Shp.Type, Shp.Name, Shp.TopLeftCell.Address(0, 0)
    If Shp.Type = msoPicture Then
        If Shp.TopLeftCell.Column = 3 And Shp.TopLeftCell.Row >= 8 Then    ' 3=col C                      'vedi nota**
            Shp.Top = Shp.TopLeftCell.Top + (Shp.TopLeftCell.Height - Shp.Height) / 2
            Shp.Left = Shp.TopLeftCell.Left + (Shp.TopLeftCell.Width - Shp.Width) / 2
        End If
    End If
Next Shp
Range("C8").Select
End Sub


Noterai le modifiche per eliminare eventuali forme dalle celle destinatarie, copiarvi la cella campione, e infine allinearle col codice preesistente

[raimea]

ciao
tutto ok
grazie