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
| Option Explicit
Private Const N As Integer = 36 'Nbre de plantes +1
Sub Main()
Dim Nb As Integer, i As Integer, j As Integer, k As Integer
Dim myDico As Object
Dim Tmp As String
Dim Tb, Tdc, RES()
Dim Na As Long
Application.ScreenUpdating = False
Feuil1.Range("AN:AO").ClearContents
ReDim RES(1 To 2, 1 To 1)
RES(1, 1) = "Associations plantes"
RES(2, 1) = "Nbre de plantes"
Set myDico = CreateObject("Scripting.Dictionary")
INI myDico, Tb
For i = 2 To N - 1
k = 1
Do
Tmp = Tb(i, 1) & ";"
Tdc = myDico(Tb(i, 1))
Nb = UBound(Tdc)
For j = k To Nb
If TROUVE(myDico, Tmp, Tdc(j)) Then
Tmp = Tmp & Tdc(j) & ";"
ECRIRE RES, Tmp
End If
Next j
k = k + 1
Loop While k <= Nb
Next i
Set myDico = Nothing
Na = UBound(RES, 2)
Feuil1.Range("AN1").Resize(Na, 2).Value = Application.Transpose(RES)
MsgBox "Teminé..." & Chr(10) & Na - 1 & " associations..."
End Sub
Private Sub INI(Dico As Object, Tbl)
Dim i As Integer, j As Integer, k As Integer
Dim Neutre As Boolean, B As Boolean
Dim Tmp() As String
Tbl = Feuil1.[A1].Resize(N, N)
Neutre = MsgBox("Voulez vous associer les plantes neutres?", vbYesNo) = vbYes
For i = 2 To N - 1
For j = i + 1 To N
If Neutre Then
B = Tbl(i, j) <> "-"
Else
B = Tbl(i, j) = "+"
End If
If B Then
k = k + 1
ReDim Preserve Tmp(1 To k)
Tmp(k) = Tbl(1, j)
End If
Next j
Dico.Add Tbl(i, 1), Tmp
k = 0
ReDim Tmp(1 To 1)
Next i
End Sub
Private Function TROUVE(ByVal Dict As Object, ByVal ST As String, ByVal Plante As String) As Boolean
Dim i As Integer, j As Integer
Dim B As Boolean
Dim Tbl, Tdc
Tbl = Split(ST, ";")
For i = 0 To UBound(Tbl) - 1
Tdc = Dict(Tbl(i))
B = False
If Tdc(1) <> "" Then
For j = 1 To UBound(Tdc)
If Tdc(j) = Plante Then
B = True
Exit For
End If
Next j
End If
TROUVE = B
If Not B Then Exit Function
Next i
End Function
Private Sub ECRIRE(Tbl, ByVal ST As String)
Dim nST As Integer, nTbl As Integer, nC As Integer, j As Integer, k As Integer, kST As Integer
Dim Ajout As Boolean, Ok As Boolean
Dim m As Long, i As Long
Dim cST, cTbl
m = UBound(Tbl, 2)
If m > 1 Then
cST = Split(ST, ";")
For i = 2 To m
cTbl = Split(Tbl(1, i), ";")
nST = UBound(cST) - 1
nTbl = UBound(cTbl)
kST = 0
For j = 0 To nST
For k = 0 To nTbl
Ok = cST(j) = cTbl(k)
If Ok Then
kST = kST + 1
Exit For
End If
Next k
If Not Ok Then Exit For
Next j
If Ok Then Exit For
Next i
End If
If kST < nST + 1 Or nST = 0 Then
If kST = nTbl + 1 And nTbl > 0 Then
m = i
If Not Ok Then m = m - 1
Else
m = m + 1
ReDim Preserve Tbl(1 To 2, 1 To m)
End If
Tbl(1, m) = Left(ST, Len(ST) - 1)
Tbl(2, m) = Len(ST) - Len(Replace(ST, ";", ""))
End If
End Sub |
Permaculture - Exploiter un tableau d'associations entre les différentes espèces végétales
Répondre avec citation
Envoyé par mosar3
Partager