Discussion :

[Elodie64eh]

Bonsoir à tous,
Je recherche une solution pour un tableau à double entrées X;Y sur des interactions entre les acteurs d'une filière (ci-joint exemple simplifié).
Pour un acteur sélection (un X), je souhaiterai avoir dans un tableau synthétique
- uniquement les acteurs avec qui il a des interactions (Y)
- et la nature de la relation (la cellule XiYi)

Je ne suis pas familière de VBA Excel et je n'arrive pas à trouver une solution (nous avons passé plusieurs heures avec des collègues...).

Pourriez-vous m'aider à transposer le problème (détaillé dans le tableur Excel ci-joint) en langage Excel / VBA?

En vous remerciant d'avance,

Bien cordialement,


interactions entre acteurs_modèle.xlsx

[goldstar]

Bonjour,

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
Sub interactions()
 
Dim laPersonne As String, laPersonneRelation As String, laRelation As String
Dim cpt_c As Integer, cpt_l As Integer, derLigneCible As Integer
 
Sheets("Interface").Range("A6:B13").ClearContents
 
laPersonneRecherche = Sheets("Interface").Range("B3")
 
For cpt_c = 2 To 5 'Parcours des colonnes B à E de la feuille [Tableau des interactions]
    If Sheets("Tableau des interactions").Cells(2, cpt_c) = laPersonneRecherche Then
        For cpt_l = 3 To 6 'parcours des lignes 3 à 6 de la feuille [Tableau des interactions]
            If Sheets("Tableau des interactions").Cells(cpt_l, 1) <> laPersonneRecherche Then
                laPersonneRelation = Sheets("Tableau des interactions").Cells(cpt_l, 1)
                derLigneCible = Sheets("Interface").Range("a" & Rows.Count).End(xlUp).Row + 1
 
                If Sheets("Tableau des interactions").Cells(cpt_l, cpt_c) <> "" Then
                    laRelation = Sheets("Tableau des interactions").Cells(cpt_l, cpt_c)
 
                    Set R = Sheets("Interface").Range("A:A").Find(laPersonneRelation, lookat:=xlWhole)
 
                    If R Is Nothing Then
                        Sheets("Interface").Cells(derLigneCible, 1) = laPersonneRelation
                        Sheets("Interface").Cells(derLigneCible, 2) = laRelation
                    End If
                End If
 
            End If
        Next cpt_l
 
    End If
Next cpt_c
 
 
End Sub

Cordialement,