Excel

Aus Thomas Wiki
Version vom 14. Mai 2018, 05:32 Uhr von Thomas (Diskussion | Beiträge) (→‎Alle Diagramme ändern: wgetText ergänzt.)
(Unterschied) ← Nächstältere Version | Aktuelle Version (Unterschied) | Nächstjüngere Version → (Unterschied)
Zur Navigation springen Zur Suche springen

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