Associer 3 listes liées en une seule complète

**Alasgard** · 18/11/2015, 00h14

Bonsoir tout le monde,

J'ai toujours pu trouver de l'aide sur ce forum lorsque j'en avais besoin et j'espère que cela se reproduira

Mon problème est le suivant:

J'ai 3 listes différentes :

Une liste composée de noms de voitures et du lieu où elles se trouvent - Liste 1
Une liste concernant les éléments à réparer sur chacune des voitures - Liste 2
Une liste concernant toutes les pièces de chacun des éléments - Liste 3

Liste 1

Clio II	Garage
Ferrari	Château
C3	Garage
Audi A4	Rue
Golf 6	Parking

Liste 2

Clio II	Phares
Clio II	Boite de vitesse
Ferrari	Siège
Ferrari	Tapis
Ferrari	Vitre
C3	Phares
C3	Vitre
Audi A4	Pot d'échappement
Golf 6	Pot d'échappement
Golf 6	Logiciel espion

Liste 3

Phares	Feux de position
Phares	Feux de croisement
Phares	Feux de routes
Pot d'échappement	-
Vitre	-
Logiciel espion	Software
Logiciel espion	Capteurs
Tapis	Tapis au sol
Tapis	Poussière d'or
Boite de vitesse	-
Siège	Revêtement cuir
Siège	Dépôt de larmes de licornes

Les listes que j'aies sont bien plus complètes que celles-ci, mais j'aimerai récupérer toutes les données dans un seul tableau et je suis certain que cela est possible par macro mais je n'arrive pas à trouver la piste de départ pour pouvoir obtenir le résultat suivant:

Clio II	Boite de vitesse	-	Garage
Clio II	Phares	Feux de position	Garage
Clio II	Phares	Feux de croisement	Garage
Clio II	Phares	Feux de route	Garage
Ferrari	Vitre	-	Château
Ferrari	Tapis	Tapis au sol	Château
Ferrari	Tapis	Poussière d'or	Château
Ferrari	Siège	Revêtement cuir	Château
Ferrari	Siège	Dépôt de larmes de licornes	Château
C3	Phares	Feux de position	Garage
C3	Phares	Feux de croisement	Garage
C3	Phares	Feux de route	Garage
C3	Vitre	-	Garage
Audi A4	Pot d'échappement	-	Rue
Golf 6	Pot d'échappement	-	Parking
Golf 6	Logiciel espion	Software	Parking
Golf 6	Logiciel espion	Capteurs	Parking

Merci par avance pour votre aide

!

**Kimy_Ire** · 19/11/2015, 10h23

Bonjour Alasgard,

Tout d'abord, félicitation pour cette présentation très complète, visuelle et compréhensible.

En revanche, un petit détail est nécessaire : quand tu parles de listes, ce sont des valeurs contenues dans des cellules Excel ?

Cordialement,
Kimy

**Alasgard** · 19/11/2015, 23h13

Merci pour ce retour, j'apprécie

Concernant les listes, oui elles sont contenues dans des cellules Excel.
À vrai dire j'ai une liste par feuille (soit 3 feuilles).
J'essaierai de faire un classeur demo ce week end

!

**Kimy_Ire** · 20/11/2015, 11h42

Bonjour Alasgard,

Tiens, teste ceci en adaptant le nom de tes feuilles et dis-moi si ça te convient !

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
Option Explicit
 
Sub Traitement()
Dim oWksh As Worksheet
Dim oRng As Range, oRng_2 As Range, oResult As Range
Dim i As Integer, n As Integer
Dim oList1() As String
Dim oCell As Range, oCell_2 As Range
 
'Supprime la feuille "Recap" si déjà existante
For Each oWksh In Worksheets
    If oWksh.Name = "Recap" Then
        Application.DisplayAlerts = False
        oWksh.Delete
        Application.DisplayAlerts = True
    End If
Next oWksh
 
'Créé la feuille "Recap"
Set oWksh = Worksheets.Add(After:=Worksheets(Worksheets.Count))
oWksh.Name = "Recap"
With oWksh
    .Range("A1") = "Mon titre 1"
    .Range("B1") = "Mon titre 2"
    .Range("C1") = "Mon titre 3"
    .Range("D1") = "Mon titre 4"
End With
 
'Avec la feuille "Liste1"
With Worksheets("Liste1")
    Set oRng = .Range("A1")
    n = 1
    For i = 0 To .Cells(.Rows.Count, oRng.Column).End(xlUp).Row - oRng.Row
        ReDim Preserve oList1(1 To 2, 1 To n)
        oList1(1, n) = oRng.Offset(i, 0)
        oList1(2, n) = oRng.Offset(i, 1)
        n = n + 1
    Next i
End With
 
'Avec la feuille "Liste2"
With Worksheets("Liste2")
    For i = LBound(oList1, 2) To UBound(oList1, 2)
        Set oRng = FindAll(.Columns(1), oList1(1, i))
        If Not oRng Is Nothing Then
            For Each oCell In oRng
                'Sur la feuille "Liste3"
                Set oRng_2 = FindAll(Worksheets("Liste3").Columns(1), oCell.Offset(0, 1))
                If Not oRng_2 Is Nothing Then
                    For Each oCell_2 In oRng_2
                        Set oResult = oWksh.Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0)
                        oResult.Offset(0, 0) = oList1(1, i)
                        oResult.Offset(0, 1) = oCell.Offset(0, 1)
                        oResult.Offset(0, 2) = oCell_2.Offset(0, 1)
                        oResult.Offset(0, 3) = oList1(2, i)
                    Next oCell_2
                Else
                    'Possibilité d'ajouter de la gestion d'erreur si on ne trouve pas de correspondance entre Liste2 et Liste3
                End If
                Set oRng_2 = Nothing
            Next oCell
        Else
            'Possibilité d'ajouter de la gestion d'erreur si on ne trouve pas de correspondance entre Liste1 et Liste2
        End If
        Set oRng = Nothing
    Next i
End With
 
End Sub

J'ai utilisé (comme à mon habitude) la fonction FindAll du net.
Place donc cette-dernière sous la Sub que je t'ai donnée ou dans un autre module.

Code de la Fonction FindAll :

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
Function FindAll(SearchRange As Range, _
                FindWhat As Variant, _
                Optional LookIn As XlFindLookIn = xlValues, _
                Optional LookAt As XlLookAt = xlWhole, _
                Optional SearchOrder As XlSearchOrder = xlByRows, _
                Optional MatchCase As Boolean = False, _
                Optional BeginsWith As String = vbNullString, _
                Optional EndsWith As String = vbNullString, _
                Optional BeginEndCompare As VbCompareMethod = vbTextCompare) As Range
 
Dim FoundCell As Range
Dim FirstFound As Range
Dim LastCell As Range
Dim ResultRange As Range
Dim XLookAt As XlLookAt
Dim Include As Boolean
Dim CompMode As VbCompareMethod
Dim Area As Range
Dim MaxRow As Long
Dim MaxCol As Long
Dim BeginB As Boolean
Dim EndB As Boolean
 
 
CompMode = BeginEndCompare
If BeginsWith <> vbNullString Or EndsWith <> vbNullString Then
    XLookAt = xlPart
Else
    XLookAt = LookAt
End If
 
 
For Each Area In SearchRange.Areas
    With Area
        If .Cells(.Cells.Count).Row > MaxRow Then
            MaxRow = .Cells(.Cells.Count).Row
        End If
        If .Cells(.Cells.Count).Column > MaxCol Then
            MaxCol = .Cells(.Cells.Count).Column
        End If
    End With
Next Area
Set LastCell = SearchRange.Worksheet.Cells(MaxRow, MaxCol)
 
On Error GoTo 0
Set FoundCell = SearchRange.Find(what:=FindWhat, _
        After:=LastCell, _
        LookIn:=LookIn, _
        LookAt:=XLookAt, _
        SearchOrder:=SearchOrder, _
        MatchCase:=MatchCase)
 
If Not FoundCell Is Nothing Then
    Set FirstFound = FoundCell
    Do Until False
        Include = False
        If BeginsWith = vbNullString And EndsWith = vbNullString Then
            Include = True
        Else
            If BeginsWith <> vbNullString Then
                If StrComp(Left(FoundCell.Text, Len(BeginsWith)), BeginsWith, BeginEndCompare) = 0 Then
                    Include = True
                End If
            End If
            If EndsWith <> vbNullString Then
                If StrComp(Right(FoundCell.Text, Len(EndsWith)), EndsWith, BeginEndCompare) = 0 Then
                    Include = True
                End If
            End If
        End If
        If Include = True Then
            If ResultRange Is Nothing Then
                Set ResultRange = FoundCell
            Else
                Set ResultRange = Application.Union(ResultRange, FoundCell)
            End If
        End If
        Set FoundCell = SearchRange.FindNext(After:=FoundCell)
        If (FoundCell Is Nothing) Then
            Exit Do
        End If
        If (FoundCell.Address = FirstFound.Address) Then
            Exit Do
        End If
 
    Loop
End If
 
Set FindAll = ResultRange
 
End Function

Par ailleurs, j'ai supposé que tes tableaux étaient positionnés sur les colonnes A et B en ligne 1.

Mais, tu auras surement des réponses de Marc ou Robert qui seront moins longue que la mienne.

Cependant, je pense que la mienne est fonctionnelle !

Cordialement,
Kimy

**Alasgard** · 22/11/2015, 16h47

Salut,

Je regarde ça dans la semaine, dès que j'ai du temps libre

!
Merci en tout cas

**Alasgard** · 23/11/2015, 23h40

Je mets le sujet en résolu car ta macro fonctionne à merveille Kimy

Je n'ai plus qu'à l'adapter à mon fichier

Après j'ai quelques questions concernant le code et la fonction FindAll en particulier ...
Cette fonction sert à déterminer la cellule dans laquelle se trouve la valeur cherchée c'est bien ça ?

Ensuite j'ai une question concernant les tableaux, je ne maîtrise pas trop la gestion de ceux-ci sous VBA et je me demandais l'utilité de redimensionner avec le "redim preserve" de la liste 1 ...

Je jetterai un coup d'oeil aux tutos mais si tu pouvais m'éclairer au sujet de ton code, ce serait top

!

Associer 3 listes liées en une seule complète [XL-2010]

Macros et VBA Excel

Vue hybride

Discussions similaires

Partager

Partager