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
| Option Explicit
Option Base 0
Public Sub buildMatrix(ByVal strStart As String)
On Error GoTo Error
Dim oSheet As Worksheet
Dim oCell As Range
Dim lMaxRows As Long
Dim strMatrix() As String
Dim strRow() As String
Dim i As Long
Dim strParent As String
Dim strEnfant As String
Set oSheet = ThisWorkbook.Sheets("Aide")
Set oCell = oSheet.Range("A2")
'// construction de la matrice
'// calcul de la taille
lMaxRows = oCell.End(xlDown).Row - 1
ReDim strMatrix(lMaxRows, lMaxRows)
'// remplissage de la 1er ligne et 1er colonne
Set oCell = oSheet.Range("B2")
For i = 1 To lMaxRows
strMatrix(i, 0) = oCell.Value
strMatrix(0, i) = oCell.Value
Set oCell = oCell.Offset(1)
Next
'// remplissage de la matrice
Set oCell = oSheet.Range("A2:B2")
For i = 1 To lMaxRows
Call getHierarchie(oCell, strParent, strEnfant)
Call setMatrix(strMatrix, strParent, strEnfant)
Set oCell = oCell.Offset(1)
Next
'// transfert vers la feuille de calcul
Set oCell = oSheet.Range(strStart)
Call pasteStringArray(strMatrix, oCell)
Exit Sub
Error:
Debug.Print "Erreur N°" & Err.Number & ": " & Err.Description
End Sub
'// transfert un tableau a 2 dimensions vers une cellule donnée
Private Sub pasteStringArray(ByRef arr() As String, ByRef oRngDestination As Range)
On Error GoTo Error
Dim NumRows As Long
Dim NumCols As Long
NumRows = UBound(arr, 1) - LBound(arr, 1) + 1
NumCols = UBound(arr, 2) - LBound(arr, 2) + 1
oRngDestination.Resize(NumRows, NumCols).Value = arr
Exit Sub
Error:
Err.Raise Err.Number, Err.Source, Err.Description, Err.HelpFile, Err.HelpContext
End Sub
'// obtient la hierarchie parent => enfant
Private Sub getHierarchie(ByRef oCells As Range, ByRef strParent As String, ByRef strEnfant As String)
On Error GoTo Error
Dim lRank As Long
Dim oCurrentCells As Range
lRank = CLng(oCells.Cells(1).Value)
strEnfant = oCells.Cells(2).Value
strParent = vbNullString
Set oCurrentCells = oCells
'// remonte les lignes a la recherche du parent
While ((oCurrentCells.Row > 1) And (strParent = vbNullString))
If (lRank > CLng(oCurrentCells.Cells(1).Value)) Then
strParent = oCurrentCells.Cells(2).Value
End If
Set oCurrentCells = oCurrentCells.Offset(-1)
Wend
If (strParent = vbNullString) Then
'// parent non trouvé
strParent = strEnfant
End If
Exit Sub
Error:
Err.Raise Err.Number, Err.Source, Err.Description, Err.HelpFile, Err.HelpContext
End Sub
Private Sub setMatrix(ByRef strMatrix() As String, ByVal strParent As String, ByVal strEnfant As String)
On Error GoTo Error
Dim x As Long
Dim y As Long
'// recherche de l'abscisse du parent
While (strParent <> strMatrix(0, x))
x = x + 1
Wend
'// recherche de l'ordonnée de l'enfant
While (strEnfant <> strMatrix(y, 0))
y = y + 1
Wend
'// attention a inverser lignes et colonnes
'// lorsque l'on transfert vers la feuille de calcul
strMatrix(y, x) = "1"
Exit Sub
Error:
Err.Raise Err.Number, Err.Source, Err.Description, Err.HelpFile, Err.HelpContext
End Sub |
