Grafikerstellung

[SteveY92]

Hallo zusammen,

ich würde gerne die Ergebnisse von Fragebögen wie die Grafiken der beigefügten Datei auswerten. Die Rohdatenmatrix ist schon erstellt. 
Kann mir hierzu einer sagen, wie ich die Grafiken aus den Daten erstellen kann? Bekomme nur mehrere Balkendiagramme hin und nicht wie das in der Datei.

MFG
S.Tomek

  Darstellung Ergebnisse Befragung.pdf (Größe: 21,61 KB / Downloads: 13)

[schauan]

Hallöchen,

das sind gestapelte Balken. Dazu nimmst Du mehrere Datenreihen, entsprechend der Vorgabe sind es 6

[Ego]

cp:

https://www.ms-office-forum.net/forum/sh...p?t=370858

[volti]

Hallo S.,

falls das nicht klappt mit der Grafik, gäbe es alternativ noch eine VBA-Lösung.

Ich als VBA-Mensch würde mir jetzt einfach pro Balken 6 Textfelder nehmen, entsprechend formatieren, geschickt benennen (z.B. "TF_Bl01_1, TF_Bl01_2") usw. und mir dann eine Funktion schreiben, die die Daten dort reinschreibt und die Balkenbreiten einstellt.

Anliegend ein einfaches Beispiel, wobei die Balkengrafik einfach an ein Range angedockt wird. Da kann man dann auch noch ein transparentes Rechteck drüberlegen oder was immer man möchte.

Hier auch mal etwas Code als Beispiel dazu, kann man natürlich ausbauen oder anders machen.

Code:

Option Explicit

Sub DiagrammAktualisieren()
  SetUmfragediagramm "TF_Bl01_", Range("E5:J5"), Range("E3:J3")
End Sub

Function SetUmfragediagramm(sGrafik As String, rBalken As Range, rData As Range)
 Dim oShp As Object, rZelle As Object, i As Integer
 Dim Wsh As Worksheet
 Dim MaxWertData As Currency, MaxWertBlk As Currency, Pkt As Currency
 Dim Links As Currency
 
 Set Wsh = rBalken.Cells(1, 1).Parent           'verwendetes Blatt

'Diagrammbreite ermitteln, passend zum angegebenen Range
 For Each rZelle In rBalken
     MaxWertBlk = MaxWertBlk + rZelle.WIDTH
 Next rZelle

'Hundert Prozentwert der Daten ermitteln
 For Each rZelle In rData
     MaxWertData = MaxWertData + rZelle.value
 Next rZelle
 Pkt = MaxWertBlk / MaxWertData                 'Pixel je Wert

 Links = rBalken.Cells(1, 1).Left               'Linke Balkenposition
 For i = 1 To 6
   With Wsh.Shapes(sGrafik & i)
      .Left = Links                             'LinkeKästchenposition
      .WIDTH = rData.Cells(1, i).value * Pkt    'Kästchenbreite
      .Top = rBalken.Cells(1, 1).Top            'Top-Position an Rangevorgabe
      .HEIGHT = rBalken.Cells(1, 1).HEIGHT
      .TextFrame2.TextRange.Characters.Text = rData.Cells(1, i).value
      Links = Links + .WIDTH                    'Nächste Kästchenposition
   End With
 Next i

End Function

_________________________
viele Grüße aus Freigericht ?
Karl-Heinz

[volti]

Hallo,

hier noch mal ein optimiertes Update...

Code:

Option Explicit

Sub DiagrammeAktualisieren()
  With Sheets("Mitarbeiterauswertung")
    SetUmfragediagramm "TF_Bl01_", .Range("D5:M5"), Sheets("Daten").Range("B3:G3")
    SetUmfragediagramm "TF_Bl02_", .Range("D7:M7"), Sheets("Daten").Range("B4:G4")
'usw.
  End With
End Sub

Function SetUmfragediagramm(sGrafik As String, rDiaRng As Range, rDataRng As Range)
 Dim oCellDia As Object, i As Integer
 Dim Pix As Currency, Links As Currency
 
 Pix = rDiaRng.Width / WorksheetFunction.Sum(rDataRng) 'Pixel je Wert
 Set oCellDia = rDiaRng.Cells(1, 1)                    'Erstes, linkes Feld des Diagramms
 Links = oCellDia.Left                                 'Linke Diagrammposition
 
 For i = 1 To 6                                        'Alle Textboxen durchgehen
  
   With oCellDia.Parent.Shapes(sGrafik & i)            'Textbox ansprechen
      .Width = rDataRng.Cells(1, i).Value * Pix        'Textboxbreite
      .Left = Links:    Links = Links + .Width         'Linke Textboxposition setzen
      .Top = oCellDia.Top                              'Top-Position an Rangevorgabe
      .Height = oCellDia.Height                        'Höhe der Textbox
      .TextFrame2.TextRange.Characters.Text _
               = rDataRng.Cells(1, i).Value            'Text aktualisieren
   End With
 
 Next i

End Function

______________________
viele Grüße aus Freigericht
Karl-Heinz