Ciao Mario ci sto lavorando, sono riuscito a sistemare i loghi dopo l'etichetta, ma comunque sorge un problema, questo lo stato attuale
il problema te lo dimostro nell'immagine successiva, i pulsanti in basso servono a visualizzare o nascondere alcune squadre oppure tutte, vedi che succede.
come vedi quando aggiorno si aggiorna tutto regolarmente, però se cancello tutte le squadre, come vedi mi rimangono i loghi, dovrebbero scomparire anche quelli, ed inoltre quando visualizzo una squadra logicamente il Logo e l'etichetta se prima non erano vicini alla serie si posizionano lontano.
si dovrebbe aggiornare tutto in base alle selezioni che faccio, comunque sono passi successivi che farò.
nel frattempo ti allego la Macro Complessa che ho aggiornato, ed inoltre avendo difficoltà nell'aggiungere il logo con la stessa macro, perche andava in conflitto, ho creato una SubRoutine che aggiunge il logo che allego anche quella.
Sub Complessa()
Dim r, c, x, y, d, p, n, T, L, H, W, LL, k, ind, rng
Sheets("Grafico2").Select
ind = ActiveWorkbook.Path & "\Immagini\"
Range("AG2:AK21") = ""
Range("AN2:AO21") = ""
rng = Range("AB2:Ak21")
n = 2
ActiveSheet.ChartObjects("Grafico 2").Activate
For x = 1 To 20
d = rng(x, 3)
p = rng(x, 4)
If p <> 0 Then
ActiveChart.FullSeriesCollecti0n(d).Select
ActiveChart.FullSeriesCollecti0n(d).Points(p).Select
With Selection
T = Int(.Top)
L = Int(.Left)
.MarkerStyle = -4142
End With
ActiveChart.FullSeriesCollecti0n(d).ApplyDataLabels
ActiveChart.FullSeriesCollecti0n(d).DataLabels.Select
ActiveChart.FullSeriesCollecti0n(d).HasLeaderLines = False
For y = p - 1 To 1 Step -1
ActiveChart.FullSeriesCollecti0n(d).Points(y).DataLabel.Delete
Next y
ActiveChart.FullSeriesCollecti0n(d).Points(p).DataLabel.Select
With Selection
.ShowSeriesName = -1
H = Int(.Height)
W = Int(.Width)
Cells(x + 1, 33) = T
Cells(x + 1, 34) = L
Cells(x + 1, 35) = H
Cells(x + 1, 36) = W
If x = 1 Then Cells(n, 40) = T: Cells(n, 41) = L: LL = Cells(n, 41): GoTo 1
k = 0
For y = 2 To n
If Cells(y, 40) = T Then LL = Cells(y, 41): k = 1: Exit For
Next y
1 If k = 1 Then
.Left = LL
Call Logo(LL, T, W, rng(x, 5)) 'richiama inserimento logo
LL = LL + 20 'aumenta il Left per la larghezza del logo
Cells(y, 41) = LL
End If
If k = 0 Then
LL = L
.Left = LL
Call Logo(LL, T, W, rng(x, 5)) 'richiama inserimento logo
LL = LL + 20 'aumenta il Left per la larghezza del logo
Cells(n, 40) = T
Cells(n, 41) = LL
n = n + 1
End If
End With
End If
Next x
Cells(1, 1).Select
MsgBox "Operazione terminata"
End Sub
questa per il logo, che è quella che hai fatto tu per inserirlo, gli passo solo i parametri che servono per posizionare il logo, la "W" è la lunghezza dell'etichetta che varia per ogni squadra, ed il 3 è lo spazio
Sub Logo(L, T, W, Img)
Dim ind
L = L + W + 3
ind = ActiveWorkbook.Path & "\Immagini\"
ActiveChart.Shapes.AddShape(msoShapeRoundedRectangle, L, T - 8, 20, 20).Select
Selection.ShapeRange.Line.Visible = msoFalse
With Selection.ShapeRange.Fill
.Visible = msoTrue
.UserPicture ind & Img
.TextureTile = msoFalse
End With
End Sub
controlla la macro perche quando hai inserito tu la tua macro nel riporto "Collection" lo inseriva come "Collecti0n" con lo zero al posto della "o" forse perche non hai scelto l'opzione giusta per allegare il codice.
per il momento un Saluto, e continuo a vedere se riesco a risolvere, il file lo hai, quindi inutile allegarlo, ma se vuoi lo allego.
Ciao Salvatore (8-D
P.S. comunque vedo che lo ha fatto anche a me modificare la "o" con lo "0"
[Modificato da by sal 23/09/2021 09:48]
se ti piace la soluzione sostienici con una DONAZIONE a piacere. Grazie
clicca qui