Diagramme bennen
29.06.2005 02:00:47
Conny
Also ich bekomme die Diagramme umbenannt, leider ist es eher ein Produkt des Zufalls, wenn ich es 5mal versuche klappts meist einmal.
Leider ist der Quelltext in ein recht umfangreiches Projekt gestrickt.
Stehe jedoch gerne für rückfragen zur Verfügung.
-------
Bei dem ganzen geht?s darum, dass ich Diagramme dynamisch erstelle, die Diaramme sind verschiedenen Typs und haben nicht alle Diagrammtitel, jedoch sollen sie vom Programm ohne großen Aufwand wieder gefunden werden. Ein Teil der Diagramme ist in einer Liste auf einem Arbeitsblatt aufgeführt, diese sollen auch die Aufgeführte Reihenfolge einhalten, andere sollen davor stehen.
-------
Gruß Conny
Sub test_dia_sortf()
Sheets("FWM_Chancen").Select
Diagramme_sortieren ("FWM_Chancen")
End Sub
Sub test_dia_sortk()
Sheets("KWM_Chancen").Select
Diagramme_sortieren ("KWM_Chancen")
End Sub
Sub Diagramme_Arbeitsmappe()
Dim tmp, s_tmp As String
Dim blatt_aktuell As String
Dim blatt_nr, diagramm_nr As Integer
tmp = "Angezeigt werden die Diagrammtitel, sollte dieser nicht vorhanden sein, so wird der 'Diagrammname' angezeigt." & vbLf
s_tmp = ""
For blatt_nr = 1 To ActiveWorkbook.Worksheets.Count
s_tmp = s_tmp & vbLf & ActiveWorkbook.Worksheets(blatt_nr).name & ":" & vbLf
blatt_aktuell = ActiveWorkbook.Worksheets(blatt_nr).name
With ActiveWorkbook.Worksheets(blatt_aktuell)
For diagramm_nr = 1 To .ChartObjects.Count
On Error GoTo keinTitel
s_tmp = s_tmp & .ChartObjects(diagramm_nr).Chart.ChartTitle.Characters.text
If diagramm_nr > 0 Then s_tmp = s_tmp & vbTab
Next diagramm_nr
If diagramm_nr = 1 Then s_tmp = s_tmp & "kein Diagramm"
s_tmp = s_tmp & vbLf
End With
Next blatt_nr
MsgBox tmp & s_tmp, , "Auflistung aller Arbeitsblätter und die darin enthaltenen Diagramme"
Exit Sub
keinTitel:
ohneTitel = ohneTitel + 1
s_tmp = s_tmp & "'" & ActiveWorkbook.Worksheets(blatt_aktuell).ChartObjects(diagramm_nr).Chart.name & "'"
Resume Next
End Sub
Sub Diagramme_Arbeitsblatt()
Dim ohneTitel As Integer ' nur intern
Dim maxanz As Integer ' hilfsvar
Dim tmp, s_tmp, t_tmp, u_tmp As String ' für die Ausgabe in der MsgBox
Dim diagramm_nr, diagramme_anz As Integer
Dim diagramm_name, diagramm_titel As String
tmp = "Angezeigt werden die Diagrammtitel, sollte dieser nicht vorhanden sein, so wird der 'Diagrammname' angezeigt." & vbLf
s_tmp = "Diagrammnr" & vbTab & "Diagrammname" & vbTab & vbTab & "Diagrammtitel" & vbLf 'MsgBox < 10
t_tmp = "Diagrammnr" & vbTab & "Diagrammname" & vbTab & vbTab & "Diagrammtitel" & vbLf 'MsgBox >=10
u_tmp = "Diagrammnr" & vbTab & "Diagrammname" & vbTab & vbTab & "Diagrammtitel" & vbLf 'MsgBox >=20
With ActiveSheet
'Anzahl der Diagramme im Datenblatt
diagramm_anz = .ChartObjects.Count
maxanz = diagramm_anz + 1
Do
diagramm_nr = maxanz - diagramm_anz
.ChartObjects(diagramm_nr).Select
diagramm_name = .ChartObjects(diagramm_nr).Chart.name
On Error GoTo keinTitel
diagramm_titel = .ChartObjects(diagramm_nr).Chart.ChartTitle.Characters.text
If diagramm_nr < 10 Then
s_tmp = s_tmp & diagramm_nr & vbTab & diagramm_name & vbTab & vbTab & diagramm_titel & vbLf
Else
If diagramm_nr < 20 Then
t_tmp = t_tmp & diagramm_nr & vbTab & diagramm_name & vbTab & vbTab & diagramm_titel & vbLf
Else
u_tmp = u_tmp & diagramm_nr & vbTab & diagramm_name & vbTab & vbTab & diagramm_titel & vbLf
End If
End If
'Anzahl reduzieren
diagramm_anz = diagramm_anz - 1
Loop Until diagramm_anz < 1
End With
'MsgBox ausgeben ( alt : neu )
MsgBox tmp & s_tmp, , "Auflistung aller im aktuellen Arbeitsblatt enthaltenen Diagramme (Teil 1)"
MsgBox tmp & t_tmp, , "Auflistung aller im aktuellen Arbeitsblatt enthaltenen Diagramme (Teil 2)"
MsgBox tmp & u_tmp, , "Auflistung aller im aktuellen Arbeitsblatt enthaltenen Diagramme (Teil 3)"
Diagramme_Arbeitsmappe
Exit Sub
keinTitel:
ohneTitel = ohneTitel + 1
diagramm_name = "'" & ActiveSheet.ChartObjects(diagramm_nr).Chart.name & "'"
Resume Next
End Sub
Sub Diagramme_sortieren(Wert As String)
Dim gp_land, temp As String
Dim diagramm_nr, diagramme_anz, gp_nr As Integer
Dim ohneTitel, gp_anz As Integer ' nur intern
With ActiveWorkbook.Worksheets(Wert)
For diagramm_nr = 1 To .ChartObjects.Count
On Error GoTo keinTitel
.ChartObjects(diagramm_nr).name = .ChartObjects(diagramm_nr).Chart.ChartTitle.Characters.text
Next diagramm_nr
For gp_nr = 1 To 20
gp_land = Listen.Cells(38 + gp_nr, 3) 'die Länder stehen auf dem Blatt "Listen(C39:C48)"
For diagramme_anz = 1 To .ChartObjects.Count
'On Error GoTo keinTitel
temp = .ChartObjects(diagramme_anz).Chart.ChartTitle.Characters.text
If gp_land = temp Then
.ChartObjects(diagramme_anz).name = "GP von " & temp & " (" & gp_nr & ")" ' keine Ahnung was das für ein Name ist
.ChartObjects(diagramme_anz).Chart.name = "GP von " & temp & " (" & gp_nr & ")" ' dies geht nicht so wirklich Zufall ohne on error gehts gar nicht
.ChartObjects(diagramme_anz).Select
.ChartObjects(diagramme_anz).ShapeRange.ZOrder msoBringToFront
gp_anz = gp_anz + 1
End If
Next diagramme_anz
Next gp_nr
End With
Diagramme_Arbeitsblatt
Exit Sub
keinTitel:
ohneTitel = ohneTitel + 1
Resume Next
End Sub