Excel

Nützliche VBA Scripte für MS Excel.

Balken mit Prozentwerten beschriften

Fehler beim Erstellen des Vorschaubildes: Datei fehlt

Balkendiagramm mit %-Werten

MS Excel bietet keine Möglichkeit die einzelnen Balken in einem gestapelten Balkendiagramm mit den Prozent- statt absoluten Werten zu beschriften.

Dieses VBA-Makro beschriftet die einzelnen Balken in einem gestapelten Balkendiagramm mit den Prozentwerten. Vorausgesetzt wird, dass die Summe in der letzten Spalte steht (siehe Beispielbild). Die Summe eines Stapels ist über dem Stapel angezeigt.

Labels in Diagramm ändern

Sub PercentLabelChart(myChart As Chart)

Dim mySeries As Series
Dim SollSeries As Series
Dim myPoint As Point
Dim i, j As Long

If myChart.SeriesCollection.Count > 2 Then
    
   Set SollSeries = myChart.SeriesCollection(myChart.SeriesCollection.Count)
      
   For i = 1 To myChart.SeriesCollection.Count - 1
           
     Set mySeries = myChart.SeriesCollection(i)
        
     For j = 1 To mySeries.Points.Count
        
       Set myPoint = mySeries.Points(j)
        
       If myPoint.HasDataLabel Then
       ' myPoint.DataLabel.Text = Format(mySeries.Values(j), "0")
         myPoint.DataLabel.Text = Format(mySeries.Values(j) / SollSeries.Values(j), "0%")
       End If
        
     Next ' j
      
   Next ' i
    
End If

End Sub

Aktives Diagramm ändern

Sub ActiveChartPercentLabeling()

If Not ActiveChart Is Nothing Then
  
  Call PercentLabelChart(ActiveChart)
  
Else

  MsgBox "Bitte ein Diagramm auswählen!", vbOKOnly, "Fehler: Aktives Diagramm"
   
End If

End Sub

Alle Diagramme ändern

Sub ModifyAllCharts()
'
' ModifyAllCharts Makro
'
' Ausgangsbefehl
'
'     ActiveChart.SeriesCollection(1).Points(1).DataLabel.Text = "33305"
'
 
Dim mySheet As Worksheet

For Each mySheet In Worksheets

  If mySheet.ChartObjects.Count > 0 Then
    Call PercentLabelChart(mySheet.ChartObjects(1).Chart)
  End If
  
Next

End Sub

wgetText

Die Funktion wgetText gibt die Antwort einer HTTP-Anfrage als Text zurück. Im Falle einer HTML-Seite ist dies der reine HTML-Code.

Public Function wgetText(url As String) As String
  
  Dim responseText As String
  Dim success As Boolean
  Dim oHTTP As WinHttp.WinHttpRequest
  Set oHTTP = New WinHttp.WinHttpRequest
  
  With oHTTP
    .Open Method:="GET", url:=url, async:=False
    .setRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 6.1; Win64; x64; Trident/7.0; rv:11.0) like Gecko"
    .setRequestHeader "Content-Type", "multipart/form-data; "
    .Option(WinHttpRequestOption_EnableRedirects) = True
    .send
    
    success = .waitForResponse()
    If success Then
      responseText = .responseText
    Else
      responseText = "Download failed"
    End If

  End With
  
  Set oHTTP = Nothing

  wgetText = responseText

End Function