VBA Graphique Bulle |
Titre du sujet : VBA Graphique Bulle par verdanto le 22/02/2023 23:05:44 Bonjour,
J’aimerais modifier une macro d’un fichier Excel que j’ai récupéré. Cette macro crée un graphique dans l’onglet EVALUATION DES RISQUES sur la base de données des colonnes F,G,H,I de l’onglet SAISIE DES RISQUES. J’aimerais que la macro prenne comme source les colonnes L,M au lieux des colonnes H,I. Que dois-je modifier dans la macro ci-dessous :
Sub bubbles() Dim bubble_breite As Integer Dim bubble_hoehe As Integer Dim fontcolor_bubble As String Dim fontstyle_bubble As String
Dim delta_x As Double Dim delta_y As Double Dim delta_delta_x As Double Dim delta_delta_y As Double Dim upper_left_x As Double Dim upper_left_y As Double
' sti: variable riskono und eingeführt Dim risikono(100) As Integer Dim wahrscheinlichkeit(100) As Integer Dim auswirkung(100) As Integer Dim counter(5, 5) As Integer Dim x As Integer Dim y As Integer Dim k As Double Dim AnzahlEintraege As Integer Dim AnzahlT As Integer Dim t As String
' Initalisierungen bubble_breite = 18 bubble_hoehe = 18 fontcolor_bubble = 1 fontstyle_bubble = "Standard"
' counter zuruecksetzen For i = 0 To 5 For j = 0 To 5 counter(i, j) = 0 Next j Next i
' bubbles loeschen Call erase_bubbles
' Anzahl Risiken AnzahlEintraege = WorksheetFunction.CountIf(Sheets("SAISIE DES RISQUES").Range("A4:A205"), ">0")
' Anzahl Zeitperioden T AnzahlT = 2 'WorksheetFunction.CountIf(Sheets("SAISIE DES RISQUES").Range("F4:Z4"), "*SM*") activeCol = 4 + (AnzahlT * 2)
For k = 1 To AnzahlT 'daten auslesen For i = 1 To 100 ' sti: variable risikono eingeführt und neue abfrage für top risiken risikono(i) = CInt(Sheets("SAISIE DES RISQUES").Cells(i + 3, 1).Value) wahrscheinlichkeit(i) = 0 auswirkung(i) = 0 If Sheets("SAISIE DES RISQUES").Cells(i + 3, 5).Value = "oui" Then If Sheets("SAISIE DES RISQUES").Cells(i + 3, activeCol).Value = " " Then wahrscheinlichkeit(i) = 0 Else wahrscheinlichkeit(i) = CInt(Sheets("SAISIE DES RISQUES").Cells(i + 3, activeCol).Value) If Sheets("SAISIE DES RISQUES").Cells(i + 3, activeCol + 1).Value = " " Then auswirkung(i) = 0 Else auswirkung(i) = CInt(Sheets("SAISIE DES RISQUES").Cells(i + 3, activeCol + 1).Value) End If Next i
' bubbles zeichnen upper_left_x = Sheets("MODELE").Cells(4, 3).Left upper_left_y = Sheets("MODELE").Cells(4, 3).Top delta_x = Sheets("MODELE").Cells(4, 3).Width delta_y = Sheets("MODELE").Cells(4, 3).Height delta_delta_x = bubble_breite + (delta_x - 3 * bubble_breite) / 10 upper_left_x = upper_left_x + (delta_x - 3 * bubble_breite) / 10 delta_delta_y = bubble_hoehe + (delta_y - 3 * bubble_hoehe) / 10 upper_left_y = upper_left_y + (delta_y - 3 * bubble_hoehe) / 10 i = 1
For u = 1 To AnzahlEintraege x = upper_left_x + (auswirkung(i) - 1) * delta_x y = upper_left_y + (5 - wahrscheinlichkeit(i)) * delta_y x = x + (counter(wahrscheinlichkeit(i), auswirkung(i)) Mod 4) * delta_delta_x y = y + ((counter(wahrscheinlichkeit(i), auswirkung(i)) - counter(wahrscheinlichkeit(i), auswirkung(i)) Mod 4) / 4) * delta_delta_y
If wahrscheinlichkeit(i) = 0 Then counter(wahrscheinlichkeit(i), auswirkung(i)) = counter(wahrscheinlichkeit(i), auswirkung(i)) + 1
Else Call add_bubble(x, y, bubble_breite, bubble_hoehe, risikono(i), k) counter(wahrscheinlichkeit(i), auswirkung(i)) = counter(wahrscheinlichkeit(i), auswirkung(i)) + 1 End If i = i + 1
Next u Cells(1, 1).Select activeCol = activeCol - 2
Next k End Sub
Sub erase_bubbles() Sheets("EVALUATION DES RISQUES").Select Application.DisplayAlerts = False ActiveWindow.SelectedSheets.Delete Sheets("MODELE").Select Sheets("MODELE").Copy After:=Sheets("SAISIE DES RISQUES") Sheets("MODELE (2)").Select Sheets("MODELE (2)").Name = "EVALUATION DES RISQUES" End Sub
Sub add_bubble(ByVal x As Double, ByVal y As Double, ByVal bubble_breite, ByVal bubble_hoehe, ByVal z As Integer, ByVal k As Double)
If k = 1 Then bubble_breite = 18 bubble_hoehe = 18 Fontfarbe_bubble = 2 fontstyle_bubble = "Bold" Else Fontfarbe_bubble = 16 End If
ActiveSheet.Shapes.AddShape(msoShapeOval, x, y, bubble_breite, bubble_hoehe).Select Selection.Characters.Text = z Selection.ShapeRange.Line.Transparency = 1
' Farbe für Bubbles bestimmen
Select Case k Case 1 Selection.ShapeRange.Fill.ForeColor.RGB = RGB(67, 69, 42) Case 2 Selection.ShapeRange.Fill.ForeColor.RGB = RGB(196, 189, 151) Selection.ShapeRange.ZOrder (1) Case 3 Selection.ShapeRange.Fill.ForeColor.RGB = RGB(238, 236, 225) Selection.ShapeRange.ZOrder (1) End Select
With Selection.Characters(Start:=0, Length:=2).Font .Name = "Arial" .FontStyle = fontstyle_bubble .Size = 8 .Strikethrough = False .Superscript = False .Subscript = False .OutlineFont = False .Shadow = False .Underline = xlUnderlineStyleNone .ColorIndex = Fontfarbe_bubble End With With Selection .HorizontalAlignment = xlCenter .VerticalAlignment = xlCenter .Orientation = xlHorizontal .AutoSize = False End With End Sub |
Forums