VBA: Bubble Chart mit Logos dynamisch
10.05.2016 12:14:20
Hewad
Die Antwort von Beverly zu meinem bisgerigen Beitrag, welche nicht mehr aktiv ist:
Hi, soweit ich weiß ist das nicht möglich. Belasse die Logos auf der Festplatte und füge sie wie gehabt ein.
Zunächst vielen Dank für den Tipp. Ich habe Logos von der Festplatte übernommen und es funktioniert auch soweit. Leider ist mein Code jedoch sehr lang, bzw ich habe für jede Reihe auf dem Diagramm seperate Codes geschrieben, die ich dann mit einem Makro per "Call" ausführe.
Ich würde gerne das Problem mit einer Schleife lösen aber wie? :-)
Zitat: alle Blasen auf einer Reihe werden mit den ensprechenden Logos befüllt. Ich möchte, wenn die Letze Blase fertig ist, die Schleife zur nächsten Reihe rübergeht und so weiter :-)
erste Reihe
Sub Image_upload_R1()
On Error Resume Next
Dim k As Integer
Dim i As Integer
Dim p As Integer
Dim sFilename As String
Dim bcontinue As Boolean
Dim spath As String
Dim strOrdner As String
Dim item_name As String
Dim fullser As FullSeriesCollection
Dim Num_bubble As Integer
Dim num_fullser As Integer
Dim bubble_order As String
Application.ScreenUpdating = False
'Pfad bestimmen
spath = Range("Main_Path")
ActiveSheet.ChartObjects("Diagramm 1").Activate
'Anzahl Serien ermitteln
num_fullser = ActiveChart.FullSeriesCollection.Count
Debug.Print varA; num_fullser
' alle Serien zurücksetzen
For k = 1 To num_fullser
ActiveChart.FullSeriesCollection(k).Select
With Selection.Format.Fill
.Visible = msoTrue
.ForeColor.ObjectThemeColor = msoThemeColorBackground1
.ForeColor.TintAndShade = 0
.ForeColor.Brightness = 0
.Solid
End With
With Selection.Format.Line
.Visible = msoTrue
.ForeColor.RGB = RGB(242, 242, 242)
End With
Next k
Num_bubble = ActiveChart.FullSeriesCollection(1).Points.Count ' Hier Reihe ändern!!!
Debug.Print varA; Num_bubble
For p = 1 To Num_bubble
'erster Treffer auf der Liste in der Zeile 62, Schleife
i = 62 'Vergleich aus der Zeile 62
bcontinue = True
While bcontinue
sFilename = ActiveSheet.Cells(i, 3).Value
bubble_order = ActiveSheet.Cells(i, 2).Value
If sFilename = "" Then
bcontinue = False
Else
For Each v In Array(" / ")
sFilename = Replace(sFilename, v, " ")
Next
Debug.Print varA; sFilename
item_name = spath & sFilename & ".jpg"
Debug.Print varA; item_name
Debug.Print varA; bubble_order
ActiveSheet.ChartObjects("Diagramm 1").Activate
ActiveChart.FullSeriesCollection(1).Points(bubble_order).Select
With Selection.Format.Fill
.Visible = msoTrue
.UserPicture (item_name)
.TextureTile = msoFalse
End With
i = i + 1
End If
Wend
Next p
End Sub
'hier muss der Code eigentlich zur nächsten Reihe springen. Ich habe es nicht 'geschafft, _
deshalb hier der zweite Code:
'zweite Reihe
Sub Image_upload_R2()
On Error Resume Next
Dim k As Integer
Dim i As Integer
Dim p As Integer
Dim sFilename As String
Dim bcontinue As Boolean
Dim spath As String
Dim strOrdner As String
Dim item_name As String
Dim fullser As FullSeriesCollection
Dim Num_bubble As Integer
Dim num_fullser As Integer
Dim bubble_order As String
Application.ScreenUpdating = False
'Pfad bestimmen
spath = Range("Main_Path")
ActiveSheet.ChartObjects("Diagramm 1").Activate
'Anzahl Serien ermitteln
num_fullser = ActiveChart.FullSeriesCollection.Count
Debug.Print varA; num_fullser
Num_bubble = ActiveChart.FullSeriesCollection(2).Points.Count ' Hier Reihe ändern!!!
Debug.Print varA; Num_bubble
For p = 1 To Num_bubble
'erster Treffer auf der Liste in der Zeile 62, Schleife
i = 62 'Vergleich aus der Zeile 62
bcontinue = True
While bcontinue
sFilename = ActiveSheet.Cells(i, 5).Value ' Vergleich der Name aus der 5. Spalte Commercial _
Pachage, ändern!!!
bubble_order = ActiveSheet.Cells(i, 4).Value ' Vergleich der Name aus der 4. Spalte _
Commercial Pachage, ändern!!!
If sFilename = "" Then
bcontinue = False
Else
For Each v In Array(" / ")
sFilename = Replace(sFilename, v, " ")
Next
Debug.Print varA; sFilename
item_name = spath & sFilename & ".jpg"
Debug.Print varA; item_name
Debug.Print varA; bubble_order
ActiveSheet.ChartObjects("Diagramm 1").Activate
ActiveChart.FullSeriesCollection(2).Points(bubble_order).Select 'Hier Reihe ändern!!!
With Selection.Format.Fill
.Visible = msoTrue
.UserPicture (item_name)
.TextureTile = msoFalse
End With
i = i + 1
End If
Wend
Next p
End Sub