Discussion :

[Quentin21000]

Bonjour, nous somme étudiants et nous avons un projet sous Vba, cependant nous avons quelques problèmes de programmation.

Je vous explique notre problème :

Voici notre code sous Vba :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
Sub PI()
Dim X, Y As Double
Dim I, J, K, Max, M, N As Long
Worksheets("Feuil1").Select
Max = Cells(1, 7)
ActiveSheet.ChartObjects("Graphique 1").Activate
ActiveChart.PlotArea.Select
ActiveChart.SeriesCollection(1).XValues = "=Feuil1!R1C5:R" & Max & "C5"
ActiveChart.SeriesCollection(1).Values = "=Feuil1!R1C6:R" & Max & "C6"
ActiveChart.Axes(xlCategory).MinimumScale = 0
ActiveChart.Axes(xlCategory).MaximumScale = Max
Worksheets("Feuil1").Cells(1, 1).Select
J = 0
K = 0
M = -10000
N = 10000
For I = 1 To Max
X = Rnd()
Y = Rnd()
If X ^ 2 + Y ^ 2 <= 1 Then
J = J + 1
Cells(J, 1) = X
Cells(J, 2) = Y
Else
K = K + 1
Cells(K, 3) = X
Cells(K, 4) = Y
End If
Cells(I, 5) = I
Cells(I, 6) = 4 * J / I
M = IIf(Cells(I, 6) > M, Cells(I, 6), M)
N = IIf(Cells(I, 6) < N, Cells(I, 6), N)
Next
ActiveSheet.ChartObjects("Graphique 1").Activate
ActiveChart.PlotArea.Select
ActiveChart.Axes(xlValue).MinimumScale = N
ActiveChart.Axes(xlValue).MaximumScale = M
End Sub

La partie

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
ActiveSheet.ChartObjects("Graphique 1").Activate
ActiveChart.PlotArea.Select
ActiveChart.SeriesCollection(1).XValues = "=Feuil1!R1C5:R" & Max & "C5"
ActiveChart.SeriesCollection(1).Values = "=Feuil1!R1C6:R" & Max & "C6"
ActiveChart.Axes(xlCategory).MinimumScale = 0
ActiveChart.Axes(xlCategory).MaximumScale = Max
Worksheets("Feuil1").Cells(1, 1).Select

est un peu compliqué et nous avons un peu de mal a la comprendre néanmoins la raison qui nous pousse a demander de l'aide n'est pas celle ci, nous recherchons à schématiser l'application de la formule de Monté Carlo a travers la surface d'un cercle dans un carré

Je vous link ce que nous cherchons a faire malheureusement nous n'arrivons pas a le coder sous Vba
http://therese.eveilleau.pagesperso-...onte_carlo.htm

Si vous pouviez nous apporter votre aide, ce serait très appréciable

Merci d'avance

[mercatog]

Une proposition à adapter
(Lancer la macro Appliquer)

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
Const N As Integer = 2500 'nombre de points à tracer
 
'Procédure d'effacement de la feuille et création d'un graphique vide mis en forme
Private Sub Preparer(ByVal Sh As Worksheet)
Dim Ch As ChartObject
 
Application.ScreenUpdating = False
With Sh
    For Each Ch In .ChartObjects
        Ch.Delete
    Next Ch
    .UsedRange.Delete
    Set Ch = .ChartObjects.Add(350, 30, 250, 250)
    With Ch.Chart
        .ChartType = xlXYScatter
        .Axes(xlValue).MaximumScale = 1.1
        .Axes(xlValue).MinimumScale = 0
        .Axes(xlCategory).MaximumScale = 1.1
        .Axes(xlCategory).MinimumScale = 0
        .HasLegend = False
        .HasTitle = False
    End With
    Set Ch = Nothing
End With
End Sub
 
'Procédure de traçage d'unz serie colorée avec Klr et pour X: Rg et Y: colonne de gauche
Private Sub Tracer(ByVal Ch As Chart, ByVal Rg As Range, ByVal Klr As Long)
 
Application.ScreenUpdating = False
With Ch.SeriesCollection.NewSeries
    .XValues = Rg
    .Values = Rg.Offset(0, 1)
    .MarkerStyle = 8
    .MarkerSize = 6
    With .Format
        .Line.Visible = msoFalse
        .Fill.ForeColor.RGB = Klr
    End With
End With
End Sub
 
'Remplissage des colonnes A et B de X et Y (cercle) et le colonnes C et D (carrée)
Private Sub Remplir(ByVal Sh As Worksheet)
Dim X As Double, Y As Double, R As Double
Dim TbC() As Double, TbD() As Double
Dim i As Integer, j As Integer, k As Integer
 
Application.ScreenUpdating = False
    Randomize
For i = 1 To N
    X = i / N
    Y = Rnd
    R = X ^ 2 + Y ^ 2
    If R <= 1 Then
        j = j + 1
        ReDim Preserve TbD(1 To 2, 1 To j)
        TbD(1, j) = X
        TbD(2, j) = Y
    Else
        k = k + 1
        ReDim Preserve TbC(1 To 2, 1 To k)
        TbC(1, k) = X
        TbC(2, k) = Y
    End If
Next i
With Sh
    .Range("A1").Resize(j, 2) = Application.Transpose(TbD)
    .Range("C1").Resize(k, 2) = Application.Transpose(TbC)
End With
End Sub
 
'Procédure de lancement
Sub Appliquer()
Dim S(1 To 2) As Double
Dim LastLig As Long
Dim Ws As Worksheet
Dim Ch As Chart
Dim i As Byte
Dim P As Double
 
Application.ScreenUpdating = False
Set Ws = Worksheets("Feuil1")
Preparer Ws
Remplir Ws
With Ws
    Set Ch = .ChartObjects(1).Chart
    For i = 1 To 2
        LastLig = .Cells(.Rows.Count, 2 * i - 1).End(xlUp).Row
        S(i) = LastLig
        Tracer Ch, .Range(.Cells(1, 2 * i - 1), .Cells(LastLig, 2 * i - 1)), RGB(255 * (i - 1), 255 * (2 - i), 0)
    Next i
    P = 4 * S(1) / (S(1) + S(2))
    With .Range("H1")
        .Value = "Pi (pour N=" & N & "): " & P
        With .Font
            .Size = 14
            .Bold = True
        End With
    End With
    Set Ch = Nothing
End With
Set Ws = Nothing
End Sub