Exercice vba

Version imprimable

05/04/2013, 08h01
wmune

Exercice vba

Partie 1 :
Un tableau Excel de n*n cellules est généré. Une forêt aléatoire est construite suivant le principe
suivant : une cellule est tirée au sort, si elle est vide, celle-ci est coloriée en vert, et contient la lettre
A (A comme Arbre). (L’inclusion de lettre est facultative, on pourra utiliser des codes de couleur),
sinon si la cellule contient déjà un arbre et la génération de la forêt s’arrête
(J'ai le code de la première partie)

Partie 2 (note jusqu’à 12/20). Version virus stupide
Un virus mangeur d’arbre apparaît dans la forêt, il se propage de façon aléatoire dans la forêt
générée. Au départ, le virus possède une quantité d’énergie maximale ET. A chaque fois que le virus
se déplace, il dépense une part de cette énergie EU. Lorsque le virus consomme toute son énergie (le
virus meurt. Si le virus mange un arbre, son énergie passe au maximum ET
Pour simplifier, on considère que chaque déplacement du virus sur une cellule du tableau coute une
unité d’énergie EU, et ET=k EU. K est une valeur arbitraire.
Paramètres d’entrées de la partie 2a
La taille n du tableau d’Excel, et la constante k.

Partie 2 b, version virus intelligent, (note jusqu’à 20/20)
Cette fois ci, le virus possède une intelligence. Il est capable de percevoir son environnement proche,
à savoir les 8 cellules voisines :
Voisin Voisin Voisin
Voisin Virus Voisin
Voisin Voisin Voisin
A/ Si un au moins un des voisins est un arbre alors le virus se déplace de façon arbitraire sur un des
arbres et le mange
Arbre
Virus
arbre
Avant déplacement
Après déplacement : Le virus s’est déplacé en bas à droite.
B/Si aucun des voisins n’est un arbre, le virus se déplace aléatoirement à partir de sa position.

S IL VOUS PLAIT AIDEZ MOI A TROUVER LE CODE POUR CETTE SECONDE PARTIE
05/04/2013, 09h30
luca.donati

Bonjour, wmune.
Ton exercice est intéressant. Pourrais-tu poster la partie de code que tu as déjà, pour qu'on puisse raisonner plus concrètement?
05/04/2013, 19h00
Theze

Bonjour,

Regarde cette discussion :
http://www.developpez.net/forums/d13...reation-virus/
Patrick et moi même avons fait plusieurs propositions qui te donnerons probablement un point de départ. Tu as le virus avec une avance totalement aléatoire et automatique et le virus intelligent avec avancement aléatoire et manuel (qu'il est possible de rendre automatique), il sait où sont ces cibles mais son déplacement vers ces dernières est aléatoire mais si une cellule saine (rouge) se trouve sur son passage (il est en direction de la cible en cours) ou dans son environnement proche elle sera infectée. Pour les tests, il te faut lire les codes et commentaires afin de savoir quoi faire.
par exemple, pour mon dernier code (le virus intelligent) la zone est A1:O36 et certaines des cellules de cette zone doivent avoir le fond colorié en rouge (le nombre importe peu) et un bouton type Formulaire doit être posé sur la feuille à qui tu affecte la macro "Virus". La marche est manuelle donc, il faut cliquer à chaque fois sur le bouton pour faire progresser le virus. Ce dernier est de couleur verte et une fois la cellule infectée, elle devient bleu. Amuse toi !

Hervé.
07/04/2013, 01h24
Marc-L

Bonsoir, deuxième post dans ce sujet !

J'ai eu le même exercice sur un autre forum il y a une semaine, j'ai même posté un message et un lien plus tôt en fin d'après-midi mais ce message a été effacé !

Merci de m'en expliquer en MP la raison.

Sinon j'ai deux approches sous le coude pour la définition des huit cellules voisines, et un fonctionnement totalement automatique du virus "intelligent" …

Bonjour,

Pour un avancement totalement automatique du virus. Lancer la proc "Virus" :

Code:

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
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
 
Declare Function GetTickCount Lib "Kernel32" () As Long
 
Dim Tbl() As Long
 
Dim Plage As Range
Dim Cel As Range
 
Dim Lgn As Long
Dim Col As Long
Dim PosCol As Long
Dim PosLgn As Long
Dim J As Long
Dim X As Long
Dim Y As Long
 
Dim Prox As Boolean
Dim Ini As Boolean
 
Sub Minuterie(Milliseconde As Long)
 
    Dim Arret As Long
 
    Arret = GetTickCount() + Milliseconde
 
    Do While GetTickCount() < Arret
 
        DoEvents
 
    Loop
 
End Sub
 
Sub Virus()
 
    Dim PlgProx As Range
    Dim CelProx As Range
    Dim C As Long
    Dim L As Long
 
    On Error GoTo Fin
 
    'initialise les variables
    If Ini = False Then
 
        Initialise
        Ini = True
 
    End If
 
    'effectue une pose d'une demi seconde
    Minuterie 500
 
    'si déjà initialisée, colore en bleu (contaminée) car la cellule est en vert (couleur du virus)
    If PosLgn <> 0 Then Plage(PosLgn, PosCol).Interior.ColorIndex = 5
 
    'supprime la couleur verte
    If Plage(Lgn, Col).Interior.ColorIndex = 10 Then Plage(Lgn, Col).Interior.ColorIndex = -4142
 
    '
    If X <> 0 Then If Plage(X, Y).Interior.ColorIndex = 10 Then Plage(X, Y).Interior.ColorIndex = -4142
 
    'évite d'incrémenter ou de décrémenter si la cible est une cellule à proximité
    If Prox = False Then
 
        'effectue un décalage de ligne et colonne en positif ou négatif selon position par rapport à la cible
        If Plage(Lgn, Col).Row < Tbl(1, J) Then Lgn = Lgn + 1
 
        If Plage(Lgn, Col).Row > Tbl(1, J) Then Lgn = Lgn - 1
 
        If Plage(Lgn, Col).Column < Tbl(2, J) Then Col = Col + 1
 
        If Plage(Lgn, Col).Column > Tbl(2, J) Then Col = Col - 1
 
    End If
 
    'pour l'effet visuel, la cellule en cours est colorée en vert
    If Plage(Lgn, Col).Interior.ColorIndex = -4142 Then Plage(Lgn, Col).Interior.ColorIndex = 10
 
    'si la couleur est rouge ou déjà en bleu
    If Plage(Lgn, Col).Interior.ColorIndex = 3 Or Plage(Lgn, Col).Interior.ColorIndex = 5 Then
 
        'si c'est la cellule cible (en rouge) incrémente pour la cible suivante
        If Plage(Lgn, Col).Address = Cells(Tbl(1, J), Tbl(2, J)).Address Then
 
            J = J + 1
 
        'sinon, si la cellule n'est pas la cellule cible mais qu'elle fait partie des cibles et qu'elle
        'n'a pas encore été contaminée (couleur bleu)
        ElseIf Plage(Lgn, Col).Interior.ColorIndex = 3 Then
 
            'redimensionne le tableau
            RedimTablo Tbl(), Lgn, Col
 
        End If
 
        'mémorise la position
        PosCol = Col
        PosLgn = Lgn
 
        'colore en vert (couleur du virus)
        Plage(Lgn, Col).Interior.ColorIndex = 10
 
    End If
 
    'si la cellule en cours n'est pas en ligne 1 ou colonne 1
    If Lgn > 1 Then L = -1
    If Col > 1 Then C = -1
 
    'mémorise pour supprimer la couleur verte de la cellule précédente
    X = Lgn
    Y = Col
 
    'défini la plage de proximité
    Set PlgProx = Plage.Range(Plage(Lgn, Col).Offset(L, C), Plage(Lgn, Col).Offset(1, 1))
 
    'parcour la plage à la recherche d'une cellule rouge
    For Each CelProx In PlgProx
 
        'si trouvée, redéfini la colonne et la ligne pour se diriger vers elle au prochain clic
        'mets la variable "Prox" à vrai et fin de boucle
        If CelProx.Interior.ColorIndex = 3 Then
 
            Col = CelProx.Column
            Lgn = CelProx.Row
            Prox = True
 
            Exit For
 
        End If
 
        'si rien trouver, pas de cellule à infecter à proximité
        Prox = False
 
    Next CelProx
 
    'appelle à nouveau pour le pas suivant
    Virus
 
Exit Sub
 
Fin:
Reinitialise
 
End Sub
 
Sub Initialise()
 
    Dim I As Long
 
    'défini la plage en dur
    Set Plage = Range("A1:O36")
 
    'la sélection
    'Set Plage = Selection
 
    'mémorise l'emplacement des cellules colorées
    For Each Cel In Plage
 
        If Cel.Interior.ColorIndex = 3 Then
 
            I = I + 1
            ReDim Preserve Tbl(1 To 2, 1 To I)
            Tbl(1, I) = Cel.Row
            Tbl(2, I) = Cel.Column
 
        End If
 
    Next Cel
 
    Randomize
 
    Lgn = Int(Rnd * Plage.Rows.Count) + 1
    Col = Int(Rnd * Plage.Columns.Count) + 1
 
    J = 1
 
    'le tableau est redistribué de façon aléatoire
    Tri Tbl
 
End Sub
 
Sub Reinitialise()
 
    Set Plage = Nothing
    Erase Tbl()
    Set Cel = Nothing
    Ini = False
    Lgn = 0
    Col = 0
    J = 0
    PosCol = 0
    PosLgn = 0
    J = 0
    Prox = False
    X = 0
    Y = 0
 
End Sub
 
Sub Tri(Tablo() As Long)
 
    Dim Dico As Object
    Dim Cle As Variant
    Dim Tempo1 As Long
    Dim Tempo2 As Long
    Dim K As Long
 
    'initialise le générateur de nombres aléatoire
    Randomize
 
    'crée le dico
    Set Dico = CreateObject("Scripting.Dictionary")
 
    'boucle tant que toutes les positions non pas été trouvées
    Do
 
        K = Int(Rnd * UBound(Tablo, 2)) + 1
 
        If K <> 0 Then
 
            If Dico.exists(K) = False Then
 
                Dico.Add K, K
 
            End If
 
        End If
 
    Loop While Dico.Count <> UBound(Tablo, 2)
 
    K = 0
 
    'réorganise le tableau pour une avancée aléatoire
    For Each Cle In Dico.Keys
 
        K = K + 1
 
        Tempo1 = Tablo(1, K)
        Tempo2 = Tablo(2, K)
 
        Tablo(1, K) = Tablo(1, Cle)
        Tablo(2, K) = Tablo(2, Cle)
 
        Tablo(1, Cle) = Tempo1
        Tablo(2, Cle) = Tempo2
 
    Next Cle
 
End Sub
 
Sub RedimTablo(Tablo() As Long, Ligne As Long, Colonne As Long)
 
    Dim M As Long
    Dim N As Long
 
    For M = 1 To UBound(Tablo, 2)
 
        'quand trouvée, la supprime en déplacant les valeurs dans les dimensions et fin de boucle M
        If Tablo(1, M) = Ligne And Tablo(2, M) = Colonne Then
 
            For N = M To UBound(Tbl, 2) - 1
 
                Tbl(1, N) = Tbl(1, N + 1)
                Tbl(2, N) = Tbl(2, N + 1)
 
            Next N
 
            Exit For
 
        End If
 
    Next M
 
    'redimensionne en supprimant la dernière dimension qui ne sert plus à rien
    ReDim Preserve Tablo(1 To 2, 1 To UBound(Tablo, 2) - 1)
 
End Sub
 
Sub Colorer()
Dim LaPlage As Range
Dim LaCel As Range
 
    Set LaPlage = Range("A1:O36")
 
    For Each LaCel In LaPlage
 
        If LaCel.Interior.ColorIndex = 5 Then LaCel.Interior.ColorIndex = 3
 
    Next LaCel
 
End Sub

Hervé.

Bonjour ! (et merci pour la réponse en MP)

Ma première approche pour les 8 cellules voisines ressemble à celle du lien plus haut, valable si le terrain de jeu commence en colonne 1 ou en ligne 1.
Là le virus est un poil "évolué", il ne revient pas sur ses trois derniers pas (tableau AD) et est invincible, il ne s'arrête que quand il a tout dévoré !

Code:

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
Function Aleat(ByVal Rg As Range) As Range
     Set Aleat = Rg(Fix(Rg.Count * Rnd) + 1)
End Function
 
 
Sub Pause(Optional P = 0.04)
      D = Timer:   F = D + P
 
    While Timer < F
       If Timer < D Then F = F - 86400: D = 0
    Wend
 
    DoEvents
End Sub
 
 
Sub ColorBug()
    Dim AD(2)
    Const CI = 44, LC = 16
      Set Rg = [A1].Resize(LC, LC)
    Rg.Clear:  Randomize
 
    Do
        With Aleat(Rg).Interior
            If .ColorIndex = CI Then Exit Do Else .ColorIndex = CI: [A1] = [A1] + 1
        End With
    Loop
 
    Set Rs = Aleat(Rg)
 
    Do
        With Rs
            .Select
            AD(2) = AD(1):  AD(1) = AD(0):  AD(0) = .Address
 
            If .Interior.ColorIndex = CI Then
               .Interior.ColorIndex = xlNone:  [A1] = [A1] - 1:  If [A1] < 1 Then Exit Do
            End If
 
            Pause
                 C = .Column > 1
                 R = .Row > 1
            Set Rc = .Offset(R, C).Resize(2 - (R And .Row < LC), 2 - (C And .Column < LC))
        End With
 
        Set Rs = Nothing
 
        For Each Cel In Rc
            If Cel.Interior.ColorIndex = CI Then Set Rs = Cel: Exit For
        Next
 
        If Rs Is Nothing Then
            Do
                Set Rs = Aleat(Rc)
 
                For Each Cel In AD
                    NO = Rs.Address = Cel:  If NO Then Exit For
                Next
            Loop While NO
        End If
    Loop
End Sub

Ma deuxième approche dans le cas où ce terrain ne commence ni en colonne 1 ni en ligne 1
est d'utiliser l'intersection du terrain et des 8 cases autour du virus et respecte l'énoncé :

Code:

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
Function Aleat(ByVal Rg) As Range
   If TypeName(Rg) = "Range" Then Set Aleat = Rg(Fix(Rg.Count * Rnd) + 1) _
                             Else Set Aleat = Range(Rg(Fix(UBound(Rg) * Rnd) + 1))
End Function
 
 
Sub ColoriagePuisRecherche()
    Const CI = 44, LC = 16
      Set Rg = [B2].Resize(LC, LC)
           K = Rg.Count
          EU = K
           M = K
    Union([A1:F1], Rg).Clear:  Randomize
 
    Do
        With Aleat(Rg).Interior
            If .ColorIndex = CI Then Exit Do Else .ColorIndex = CI: N = N + 1
        End With
    Loop
 
      [A1] = N
    Set Rs = Aleat(Rg)
 
    Do
        With Rs
            .Select:  EU = EU - 1
 
            If .Interior.ColorIndex = CI Then
               .Interior.ColorIndex = xlNone:  N = N - 1
                If EU < M Then M = EU
                If N = 0 Then [C1] = "EU :  " & EU:  [E1] = "EU mini :  " & M:  Exit Do
                EU = K
 
            ElseIf EU = 0 Then
                .Value = "    MORT !":  [C1] = "Reste :  " & N:  Exit Do
            End If
 
            Set Rc = Application.Intersect(.Offset(-1, -1).Resize(3, 3), Rg)
                 A = .Address
        End With
 
        CA = ""
 
        For Each Cel In Rc
            If Cel.Interior.ColorIndex = CI Then CA = CA & " " & Cel.Address
        Next
 
        Do
            If CA = "" Then Set Rs = Aleat(Rc) Else Set Rs = Aleat(Split(CA))
        Loop While Rs.Address = A
    Loop
End Sub

08/04/2013, 16h01
Invité

1 pièce(s) jointe(s)

Une variante pour inspiration !
08/04/2013, 17h12
Marc-L

On ne peut pas tous forcément télécharger …

S'il n'y a pas trop une plâtrée de lignes, j'aurai bien aimé voir le code …

Code de la UserForm1

Code:

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
Dim ControlIndex As Long
 
Private Sub Label1_Click()
charge
Label1.Visible = False
Label2.Visible = True
Label3.Visible = False
 
End Sub
 
Private Sub Label2_Click()
supprimer
 
End Sub
 
Private Sub Label3_Click()
End
End Sub
 
 
Sub charge()
TimerOff
Dim x As Long
Dim y As Long
Dim existe As Boolean
While existe = False
x = Int(Me.Height * Rnd)
y = Int(Me.Width * Rnd)
If x = 0 Then x = 1
If y = 0 Then y = 1
CreerImage x, y
existe = ArbreExiste(MyMij(UBound(MyMij)))
Wend
TimerTsart
End Sub
Function ArbreExiste(o As Object) As Boolean
Dim i As Long
For i = 0 To UBound(MyMij) - 1
    If MyMij(i).Left = o.Left Or MyMij(i).Top = o.Top Then
        ArbreExiste = True
        Exit Function
    End If
Next
End Function
Sub CreerImage(x As Long, y As Long)
ReDim Preserve MyMij(ControlIndex)
Set MyMij(ControlIndex) = Me.Controls.Add("Forms.Image.1", "Arbre" & ControlIndex)
MyMij(ControlIndex).Picture = Me.Model.Picture
MyMij(ControlIndex).PictureSizeMode = Me.Model.PictureSizeMode
MyMij(ControlIndex).BorderStyle = Me.Model.BorderStyle
MyMij(ControlIndex).Height = Model.Height
MyMij(ControlIndex).Width = Model.Width
MyMij(ControlIndex).BackStyle = fmBackStyleTransparent
MyMij(ControlIndex).PictureSizeMode = fmPictureSizeModeZoom
MyMij(ControlIndex).BackStyle = fmBackStyleTransparent
MyMij(ControlIndex).BorderStyle = fmBorderStyleNone
MyMij(ControlIndex).Top = x
MyMij(ControlIndex).Left = y
MyMij(ControlIndex).Visible = True
ControlIndex = ControlIndex + 1
End Sub
Public Sub supprimer()
TimerOff
Dim i As Long
For i = 0 To UBound(MyMij)
Me.Controls.Remove MyMij(i).Name
Next
ControlIndex = 0
Label1.Visible = True
Label2.Visible = False
Label3.Visible = True
End Sub

Code du module

Code:

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
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
Option Explicit
Public MyMij() As Object
Private Declare Function SetTimer Lib "User32" _
    (ByVal hWnd As Long, ByVal nIDEvent As Long, _
        ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
 
Private Declare Function KillTimer Lib "User32" _
    (ByVal hWnd As Long, ByVal nIDEvent As Long) As Long
 
 Dim TimerID As Long
 Public EnMarche As Boolean
 Const nb = 50
 Const pas = 50
 Dim scor As Integer
 
Sub TestChrono()
 UserForm1.Show
End Sub
 
Sub TimerOff()
 KillTimer 0, TimerID
 EnMarche = False
End Sub
 
Sub TimerOn(Interval As Long)
 TimerID = SetTimer(0, 0, Interval, AddressOf Chrono)
End Sub
 
Sub Chrono()
 If EnMarche = True Then
 deplacement
 End If
End Sub
 
 
 
 Sub TimerTsart()
  If EnMarche = False Then
    TimerOn 100
    EnMarche = True
  End If
End Sub
Function AlerVers() As Boolean
Dim i As Long
Dim l As Long
Dim t As Long
For i = 0 To UBound(MyMij)
    If MyMij(i).Visible = True Then
        l = MyMij(i).Left - UserForm1.virus.Left
        t = MyMij(i).Top - UserForm1.virus.Top
        If Abs(l) < 101 And Abs(t) < 101 Then
            If t > 0 Then
                If Abs(t) < pas Then
                    UserForm1.virus.Top = UserForm1.virus.Top + (t + 1)
                Else
                    UserForm1.virus.Top = UserForm1.virus.Top + pas
                End If
 
            Else
                If Abs(t) < pas Then
                    UserForm1.virus.Top = UserForm1.virus.Top - (t + 1)
                Else
                     UserForm1.virus.Top = UserForm1.virus.Top - pas
                End If
 
            End If
             If l > 0 Then
             If Abs(l) < pas Then
                UserForm1.virus.Left = UserForm1.virus.Left + (l + 1)
             Else
                UserForm1.virus.Left = UserForm1.virus.Left + pas
             End If
 
            Else
                If Abs(l) < pas Then
                UserForm1.virus.Left = UserForm1.virus.Left - (l + 1)
             Else
                 UserForm1.virus.Left = UserForm1.virus.Left - pas
             End If
 
            End If
            AlerVers = True
            Exit Function
        End If
       ' Exit Function
    End If
Next
End Function
Sub deplacement()
Dim D As Integer
D = Int(3 * Rnd)
If AlerVers = False Then
    Select Case D
        Case 0
            UserForm1.virus.Left = UserForm1.virus.Left - pas
            If UserForm1.virus.Left < 1 Then UserForm1.virus.Left = UserForm1.Width
        Case 1
            UserForm1.virus.Left = UserForm1.virus.Left + pas
            If UserForm1.virus.Left > UserForm1.Width Then UserForm1.virus.Left = 1
        Case 2
            UserForm1.virus.Top = UserForm1.virus.Top - pas
            If UserForm1.virus.Top < 1 Then UserForm1.virus.Top = UserForm1.Height
        Case 3
            UserForm1.virus.Top = UserForm1.virus.Top + pas
            If UserForm1.virus.Top > UserForm1.Height Then UserForm1.virus.Top = 1
        End Select
 End If
    verifScor
    If IsGagne = True Then
        EnMarche = False
        MsgBox "Virus Gagnant"
        UserForm1.supprimer
     End If
     If scor = 0 Then
        EnMarche = False
        MsgBox "Virus Perdant"
        UserForm1.supprimer
     End If
End Sub
Sub verifScor()
Dim i As Long
For i = 0 To UBound(MyMij)
    If MyMij(i).Visible = True And (UserForm1.virus.Top >= MyMij(i).Top) And (UserForm1.virus.Top <= MyMij(i).Top + MyMij(i).Height) Then
        If MyMij(i).Visible = True And (UserForm1.virus.Left >= MyMij(i).Left) And (UserForm1.virus.Left <= MyMij(i).Left + MyMij(i).Width) Then
            MyMij(i).Visible = False
            scor = nb
            Exit Sub
        End If
    End If
 
Next
scor = scor - 1
End Sub
Function IsGagne() As Boolean
IsGagne = True
Dim i As Long
For i = 0 To UBound(MyMij)
    If MyMij(i).Visible = True Then
        IsGagne = False
        Exit Function
    End If
Next
End Function

09/04/2013, 11h03
Marc-L

Merci ! Intéressant aussi.

Peu d'étudiants l'exploiteront sauf s'ils sont d'un bon niveau ou bûchent l'aide afin de pouvoir "justifier" le code ! …

Nouvelle mouture, dans une feuille Excel seulement.

Après j’arrête

Code:

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
105
106
107
108
109
110
111
112
113
114
Dim plage As Range
Dim cl As Long
Dim rl As Long
Const ET = 2000
Dim EU As Long
Const RwMx = 30
Const ColMax = 30
Sub virus2()
 
Set plage = Range(Cells(1, 1).Address & ":" & Cells(RwMx, ColMax).Address)
plage = ""
plage.Select
 plage.Interior.Pattern = xlNone
  plage.ColumnWidth = 0.71
 plage.Rows.RowHeight = 10.5
 cl = CLng(plage.Columns.Count * Rnd)
 If cl = 0 Then cl = 1
 rl = CLng(plage.Rows.Count * Rnd)
 If cl = 0 Then cl = 1
 While plage(rl, cl).Interior.Color <> 5296274
 
 plage(rl, cl).Interior.Color = 5296274
 cl = CLng(plage.Columns.Count * Rnd)
 If cl = 0 Then cl = 1
 rl = CLng(plage.Rows.Count * Rnd)
 If rl = 0 Then rl = 1
 Wend
 EU = ET
 While FinPartie = False And EU > 0
 
D = Int(3 * Rnd)
 
    Select Case D
        Case 0
             cl = cl - 1
             If cl = 0 Then cl = plage.Columns.Count
            If Marque(plage(rl, cl)) = True Then plage8 plage(rl, cl)
        Case 1
            cl = cl + 1
            If cl > plage.Columns.Count Then cl = 1
            If Marque(plage(rl, cl)) = True Then plage8 plage(rl, cl)
        Case 2
            rl = rl - 1
            If rl = 0 Then rl = plage.Rows.Count
            If Marque(plage(rl, cl)) = True Then plage8 plage(rl, cl)
        Case 3
            rl = rl + 1
            If rl > plage.Rows.Count Then rl = 1
            If Marque(plage(rl, cl)) = True Then plage8 plage(rl, cl)
        End Select
 
 
     If Marque(plage(rl, cl)) = True Then plage8 plage(rl, cl)
 Wend
  If EU > 0 Then
         MsgBox "Virus Gagnant"
  Else
        MsgBox "Virus Perdant"
 
  End If
 
End Sub
Function FinPartie() As Boolean
Dim C As Long
Dim L As Long
FinPartie = True
For L = 1 To plage.Rows.Count
    For C = 1 To plage.Columns.Count
        If Trim("" & plage(L, C)) <> "*" And plage(L, C).Interior.Color = 5296274 Then
            FinPartie = False
            Exit Function
        End If
    Next
 Next
End Function
 
Function Marque(Mycell As Range) As Boolean
Mycell.Select
If Trim("" & Mycell) <> "*" And Mycell.Interior.Color = 5296274 Then
    Mycell = "*"
    Marque = True
    EU = ET
    Exit Function
End If
EU = EU - 1
End Function
Sub plage8(Mycell As Range)
Dim MyPlage8 As Range
Dim Rw1 As Long
Dim Rw2 As Long
Dim Col1 As Long
Dim Col2 As Long
Dim C As Long
Rw1 = Range(Mycell.Address).Row - 1
If Rw1 < 1 Then Rw1 = 1
Rw2 = Range(Mycell.Address).Row + 1
If Rw2 > RwMx Then Rw2 = RwMx
 
Col1 = Range(Mycell.Address).Column - 1
If Col1 < 1 Then Col1 = 1
Col2 = Range(Mycell.Address).Column + 1
If Col2 > ColMax Then Col2 = ColMax
 
 
Set MyPlage8 = Range(Cells(Rw1, Col1).Address & ":" & Cells(Rw2, Col2).Address)
'MyPlage8.Select
For C = 1 To MyPlage8.Count
    If Trim("" & MyPlage8(C)) <> "*" And MyPlage8(C).Interior.Color = 5296274 Then
    MyPlage8(C) = "*"
      EU = ET
 
    End If
Next
End Sub

09/04/2013, 16h35
Theze

Bonjour toutes et tous,

rdurupt, je pense qu'il n'est vraiment plus la peine de se casser la tête vu l'intérêt porté à nos réponses par wmune, et en plus, elle cri au secours :

Citation:

S IL VOUS PLAIT AIDEZ MOI A TROUVER LE CODE POUR CETTE SECONDE PARTIE

Hervé.
10/04/2013, 12h31
Marc-L
P'tites remarques sur le dernier code :
- à propos de la ligne n°10 :
  
  Code:
  
  Set plage = Range(Cells(1, 1).Address & ":" & Cells(RwMx, ColMax).Address)
  
  La propriété .Address n'est pas nécessaire si on évite la forme avec les ":" vu que Range(…) accepte d'autres Range en son sein,
  cette ligne peut alors se simplifier ainsi :
  
  Code:
  
  Set plage = Range("A1", Cells(RwMx, ColMax))
  
  Cette zone peut aussi se définir comme l'extension de la cellule A1 sur x lignes et y colonnes :
  
  Code:
  
  Set plage = [A1].Resize(RwMx, ColMax)
- Une plage avant d'être subdivisée en lignes et colonnes est d'abord un ensemble de cellules de 1 au nombre total de cellules.
  Donc une cellule peut être tirée au sort directement par rapport aux numéros de cellules de la plage sans tenir compte de la subdivision lignes / colonnes :
  
  Code:
  
  Set Cellule = Plage(Fix(Plage.Count * Rnd) + 1)
  
  Et là il n'y a plus besoin de contrôler si la cellule se trouve hors plage …
10/04/2013, 13h03
patricktoulon

heu

bonjour

comme l'a dit theze le sujet a déjà été posé de la meme manière

avec les meme condition

il t'a donné le lien
la dernière proposition que j'ai faite dans ce poste permet un visuel assez rigolo
puisque le virus est représenté par un petit shapes se déplaçant en diagonale,verticalement et horizontalement (code conçu par mercatog et moi meme

je te suggère aller faire un tour ici
si il le faut je peut te redonner le code
j'ai garder un exemplaire
au plaisir
10/04/2013, 14h25
Marc-L

J'adore … Comme indiqué dans le message avec mes codes, je l'ai donc déjà lu !

J'ai eu exactement le même énoncé sur un autre forum et mon code a été validé par une étudiante …

Donc je ne vois pas bien le rapport entre ta réponse et mes amicales remarques pour simplifier du code,
car il n'y a pas besoin de plus de 100 lignes pour répondre à cet énoncé !

Je trouve juste dommage de convertir un Range en une adresse texte pour de suite la reconvertir en Range, autant rester en Range, non ?
Pourquoi effectuer deux calculs pour tirer au sort une cellule alors qu'un seul suffit ?
C'était tout ! …

C'est comme souvent je vois dans le code pour trouver la dernière saisie d'une colonne avec la propriété .End(xlUp),
en dehors du fait de l'adresse de la dernière cellule y est souvent en dur alors qu'entre les versions d'Excel il n'y a pas le même nombre de lignes (!),
la cellule renvoyée donc par cette propriété est transformée en n° de ligne pour de suite la reconvertir en Range
et ce, même par des intervenants réguliers "gradés" de ce forum !

S'il faut ménager des susceptibilités, je m'en excuse, mais tel n'était pas le but !
10/04/2013, 16h04
patricktoulon

re

re
En fait miiranda et wmune doivent etre dans la meme classe
et doivent rendre le meme exercice :mouarf::mouarf::mouarf:

heu...Au plaisir
10/04/2013, 16h30
Marc-L

Et j'en ai eu une troisième sur un autre forum avec le même énoncé …

Quoiqu'il puisse s'agir de la même personne avec différents pseudos, sait-on jamais ?! 8-)
10/04/2013, 16h34
patricktoulon

re

Re
en ayant relu le post de miiranda elle a eue trois proposition cohérente

je ne vois pas trop l'intérêt de poster 3 fois la meme question sous 3 pseudo différents

enfin on est pas dans sa tète :mouarf::mouarf::mouarf::mouarf:
10/04/2013, 16h53
Marc-L

Logique évidente ! ;)

Mais comme souvent le code proposé est par trop évolué pour les étudiants, ils aimeraient obtenir une réponse plus proche des cours dispensés …

Récemment sur un autre forum un étudiant a été grillé vu qu'il postait sur plusieurs forums la même question sans se préoccuper des réponses des autres;
il a depuis créé d'autres pseudos (dont un ici) pour poster ses besoins partie par partie, en gros il fait faire l'intégralité de son travail sans se fouler …

J'en croise aussi un autre (sur ce forum entre autres) qui, lorsque la réponse n'est pas intégrée directement à son code
(ne veut surtout pas se donner la peine), change alors sans vergogne de forum et recommence …