rassembler les familles

**jtsfab** · 13/10/2020, 23h22

Bonjour,

J'ai un tableau indiquant les couples de familles P1=P2 ( onglet comparaison)
J'ai une liste de chaque familles qui ont plusieurs sous familles P/T (onglet liste)
P1 Pouvant avoir plusieurs sous familles

Je souhaites avoir en résultat TP1=TP2 ( attention inversion avec l'onglet liste , T en 1er et P en 2eme )

J'espère qu'avec le tableau en PJ cela sera plus claire !!

l'excellent 78chris m'avais fait le boulot avec powerquery : https://www.developpez.net/forums/d2...bler-familles/
mais impossible a installer au boulot !!!
donc solution VBA

Voici le lien vers le fichier car impossible de mettre une pièce jointe ???
https://www.grosfichiers.com/5ptnDLPdsMd

Merci d'avance

**ARTURO83** · 14/10/2020, 10h44

Bonjour,

Ceci:

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
Sub Resultat()
    Dim f1 As Worksheet, f2 As Worksheet, f3 As Worksheet
    Dim DerLig_f1 As Long, DerLig_f2 As Long, DerLig_f3 As Long
    Dim c As Long, i As Long, j As Long
    Dim Dep As String
    Application.ScreenUpdating = False
    Set f1 = Sheets("Comparaison")
    Set f2 = Sheets("Liste")
    Set f3 = Sheets("Resultat")
 
    DerLig_f1 = f1.Range("A" & Rows.Count).End(xlUp).Row
    DerLig_f2 = f2.Range("A" & Rows.Count).End(xlUp).Row
    For c = 1 To 2
        DerLig_f3 = 2
        For i = 2 To DerLig_f1
            P = f1.Cells(i, c)
            With f2.Range(f2.Cells(1, "A"), f2.Cells(DerLig_f2, "A"))
                Set x = .Find(P, lookat:=xlWhole)
                If Not x Is Nothing Then
                    Dep = x.Address
                    Do
                        f3.Cells(DerLig_f3, c) = x & "-" & f2.Cells(x.Row, "B")
                        DerLig_f3 = DerLig_f3 + 1
                        Set x = .FindNext(x)
                    Loop While Not x Is Nothing And x.Address <> Dep
                End If
            End With
        Next i
    Next c
    Set x = Nothing
    Set f1 = Nothing
    Set f2 = Nothing
    Set f3 = Nothing
End Sub

Cdlt

**BENNASR** · 14/10/2020, 11h49

bonjour
à tester

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
Sub regroup()
Application.ScreenUpdating = False
Dim F1 As Worksheet
Dim f2 As Worksheet
Dim f3 As Worksheet
Dim Dercol As Long
Set F1 = Sheets("COmparaison")
Set f2 = Sheets("Liste")
Set f3 = Sheets("Resultat")
f3.Cells.ClearContents
Dim i As Long
Set d = CreateObject("Scripting.Dictionary")
Set Q = CreateObject("Scripting.Dictionary")
    '**********************************************************
    TblBD = F1.Range("A2:B" & F1.Range("B" & Rows.Count).End(xlUp).Row)
    TblBD2 = f2.Range("A2:B" & f2.Range("B" & Rows.Count).End(xlUp).Row)
    For i = 1 To UBound(TblBD)
    For j = 1 To UBound(TblBD2)
    If TblBD(i, 1) = TblBD2(j, 1) Then
    clé = TblBD(i, 1) & "-" & TblBD2(j, 2)
    d(clé) = TblBD(i, 1) & "-" & TblBD2(j, 2)
    End If
 
    If TblBD(i, 2) = TblBD2(j, 1) Then
    clé2 = TblBD(i, 2) & "-" & TblBD2(j, 2)
    Q(clé2) = TblBD(i, 2) & "-" & TblBD2(j, 2)
    End If
 
    Next j
    Next i
  f3.Range("A1").Value = "TxP1"
  f3.Range("B1").Value = "TxP2"
 f3.Range("A2").Resize(d.Count) = Application.Transpose(d.keys)
   f3.Range("B2").Resize(d.Count) = Application.Transpose(Q.keys)
  Application.ScreenUpdating = True
  End Sub

**jtsfab** · 14/10/2020, 22h21

Merci encore à Arturo et a Bennasr

Par contre le résultat souhaité était TxP , et la c'est PxT .

Etant une Quiche , je n'arrive pas a changer le code !!

Désolé de vous solliciter a nouveau

Et encore merci

**ARTURO83** · 15/10/2020, 06h37

Bonjour,

je n'arrive pas a changer le code !!

Concernant mon code, il suffisait de faire une inversion au niveau de cette ligne

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

f3.Cells(DerLig_f3, c) = x & "-" & f2.Cells(x.Row, "B")

et de la remplacer par:

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

f3.Cells(DerLig_f3, c) = f2.Cells(x.Row, "B") & "-" & x

Toujours en ce qui concerne mon code, je n'ai pas pensé un seul instant qu'il pouvait y avoir plusieurs milliers de lignes, alors que BENNASR que je salue, y a penser en utilisant les dictionnaires, ce qui, pour une une grande quantité de lignes est beaucoup plus rapide.
Je vous propose une autre façon de faire qui se rapproche de la solution avec dictionnaire, mais ici avec les tableaux, histoire de ne pas faire la même chose et ainsi avoir plusieurs solutions?

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
Sub Resultat()
    Dim f1 As Worksheet, f2 As Worksheet, f3 As Worksheet
    Dim DerLig_f1 As Long, DerLig_f2 As Long, DerLig_f3 As Long, n As Long
    Dim c As Long, i As Long, j As Long
    Dim Dep As String
    Application.ScreenUpdating = False
    Set f1 = Sheets("Comparaison")
    Set f2 = Sheets("Liste")
    Set f3 = Sheets("Resultat")
    f3.Cells.ClearContents
    DerLig_f1 = f1.Range("A" & Rows.Count).End(xlUp).Row
    DerLig_f2 = f2.Range("A" & Rows.Count).End(xlUp).Row
    ReDim Tabl(DerLig_f1 * DerLig_f2) As String
    For c = 1 To 2
        n = 1
        DerLig_f3 = 2
        For i = 2 To DerLig_f1
            P = f1.Cells(i, c)
            With f2.Range(f2.Cells(1, "A"), f2.Cells(DerLig_f2, "A"))
                Set x = .Find(P, lookat:=xlWhole)
                If Not x Is Nothing Then
                    Dep = x.Address
                    Do
                        Tabl(n) = f2.Cells(x.Row, "B") & "-" & x
                        n = n + 1
                        DerLig_f3 = DerLig_f3 + 1
                        Set x = .FindNext(x)
                    Loop While Not x Is Nothing And x.Address <> Dep
                End If
            End With
        Next i
        Range(f3.Cells(1, c), f3.Cells(DerLig_f3 - 1, c)) = Application.WorksheetFunction.Transpose(Tabl)
    Next c
    f3.Range("A1:B1") = Array("TxP1", "TxP2")
 
    Set x = Nothing
    Set f1 = Nothing
    Set f2 = Nothing
    Set f3 = Nothing
End Sub

Cdlt

**jtsfab** · 15/10/2020, 08h46

Merci Arturo :

Je crois qu'il y a un problème avec la macro : TOTM et PMRQ.xlsm

J'ai dans résultat en fin de tableau une colonne vide , et en regardant le P de la TP , et je compare avec P1 et P2 ca corresponds pas .

Désolé de cette mauvaise nouvelle .

Pouvez vous regarder ?

rassembler les familles [XL-2013]

Macros et VBA Excel

Vue hybride

Discussions similaires

Partager

Partager