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 ?

**ARTURO83** · 15/10/2020, 09h54

Bonjour,

Effectivement sur le tableau réel il y a un petit problème, je n'ai pas trop le temps de chercher pour le moment, alors je vous propose la macro initiale modifiée, pour l'autre je regarderai plus tard.

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 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")
    f3.Cells.ClearContents
    f3.Range("A1:B1") = Array("TxP1", "TxP2")
    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) = f2.Cells(x.Row, "B") & "-" & x
                        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

**ARTURO83** · 15/10/2020, 10h01

Après réflexion, il me semble que le problème vient du fait qu'il y ait plus de 64000 lignes dans les listes, ce qui dépasse les limites des tableaux et des dictionnaires.

Cela reste à confirmer.

Cdlt

**jtsfab** · 15/10/2020, 11h03

Merci ARturo ,

La macro de BENNASR semble fonctionner .Mais bon pas sur !!

Mais le resultat est PxT au lieu de TxP .

Peut etre possible de casser le resultat en deux ??

Pas grave si j'ai deux tableaux

**ARTURO83** · 15/10/2020, 13h01

Question: Comment faites-vous pour savoir si le résultat obtenu est correct?

Quelques constatations:
-les résultats obtenus ne peuvent pas finir sur la même ligne, pour m'en assurer, j'ai comptabiliser par formule les quantités de P1 et P2 dans la feuille "Liste" (les formules sont remplacées par les valeurs pour ne pas ralentir la macro)
-la quantité de P1 =1766 et P2 =1770
-Il y a des doublons aux lignes 60 et 61 de la feuille "Comparaison", ce qui réapparaît dans la feuille "Résultat" aux lignes 112 à 115. Si on déduit 2 doublons on retrouve bien le nombre de lignes obtenu par calcul dans la feuille "Liste".

Le fichier pour vérifier
https://mon-partage.fr/f/NMu1o67G/

Cdlt

**ARTURO83** · 15/10/2020, 13h23

La même chose, mais avec utilisation des tableaux.

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
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
    Deb = Timer
    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
    For c = 1 To 2
        ReDim tabl(60000) As String
        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
        f3.Range(f3.Cells(1, c), f3.Cells(DerLig_f3 - 1, c)) = Application.WorksheetFunction.Transpose(tabl)
        Erase tabl()
    Next c
    f3.Range("A1:B1") = Array("TxP1", "TxP2")
    MsgBox "Durée: " & Timer - Deb & "Sec"
    Set x = Nothing
    Set f1 = Nothing
    Set f2 = Nothing
    Set f3 = Nothing
End Sub

**Alex020181** · 16/10/2020, 00h08

Bonsoir

J'ai lu en diagonale ce fil.

Attention Bennassar; application.transpose est limité à des tableaux de 65535 max...

**jtsfab** · 16/10/2020, 07h35

merci a tous pour votre aide , je vais revoir mes données sources et reessayer

et je reviens vers vous

**BENNASR** · 16/10/2020, 09h39

bonjour à tous
1- application transpose se limite à 65535 (merci ARTUR & Alex pour l'info que je ne connais pas

) .. j'e viens de voir sur le net que pour contourner cet handicap, il est recommander de scinder si possible les données de départ en deux tableaux

2- pour jtsfab :

le résultat souhaité était TxP

malgré que selon un petit test et vu qu'il ya deux boucle ce code consomme du temps

pour test :

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
Sub regroup()
Application.ScreenUpdating = False
Dim F1 As Worksheet
Dim f2 As Worksheet
Dim f3 As Worksheet
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("A" & Rows.Count).End(xlUp).Row)
    TblBD2 = f2.Range("A2:B" & f2.Range("A" & 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é = TblBD2(j, 2) & "-" & TblBD(i, 1)
    d(clé) = TblBD2(j, 2) & "-" & TblBD(i, 1)
    End If
    If TblBD(i, 2) = TblBD2(j, 1) Then
    clé2 = TblBD2(j, 2) & "-" & TblBD(i, 2)
    Q(clé2) = TblBD2(j, 2) & "-" & TblBD(i, 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

BONNE CONTINUATION

**jtsfab** · 16/10/2020, 16h09

Bonjour,

J'ai une erreur ,est ce parce qu'il ne trouve pas une cellule d'une feuille par rapport a l'autre feuille ?

www.grosfichiers.com/VXy3a473ggg

cdt

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

Bonjour,

Ligne 2159 de la feuille "Comparaison", il y a une formule qui renvoie "REF".

Cdlt

**BENNASR** · 16/10/2020, 16h48

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 regroup()
Application.ScreenUpdating = False
Dim F1 As Worksheet
Dim f2 As Worksheet
Dim f3 As Worksheet
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("A" & Rows.Count).End(xlUp).Row)
    TblBD2 = f2.Range("A2:B" & f2.Range("A" & Rows.Count).End(xlUp).Row)
    On Error Resume Next
    For i = 1 To UBound(TblBD)
    For j = 1 To UBound(TblBD2)
    If TblBD(i, 1) = TblBD2(j, 1) Then
    clé = TblBD2(j, 2) & "-" & TblBD(i, 1)
    d(clé) = TblBD2(j, 2) & "-" & TblBD(i, 1)
    End If
    If TblBD(i, 2) = TblBD2(j, 1) Then
    clé2 = TblBD2(j, 2) & "-" & TblBD(i, 2)
    Q(clé2) = TblBD2(j, 2) & "-" & TblBD(i, 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

**Alex020181** · 16/10/2020, 17h16

Voici ma petite participation.

Je n'ai pas utilisé les dictionnaires mais les tableaux à plusieurs dimensions.

Tu as 2 méthodes.
La première parcoure d'un bout à l'autre les 2 tableaux et la seconde ne parcoure que partiellement le tableau liste puisque le code commence par trier les données.

Le code reprend chacune des cellules en colonne "A" de la feuille "COmparaison" et les compare avec la colonne "A" de la feuille "Liste" pour sortir les comparaisons:
- "B" de liste concaténée avec "A" de "COmparaison"
- et "B" de liste concaténée avec "B" de "COmparaison"

Avec l'échantillon fourni j'ai 8 et 10 secondes de traitement sur mon PC.

Teste et dis-nous.

**Alex020181** · 16/10/2020, 19h09

Et voici avec le dernier fichier transmis contenant toutes les données.
3min16 avec la méthode 1 et 2min13 avec la méthode 2.

Mais la question principale est "est-ce bien ce que tu voulais comme résultat ?"
https://www.grosfichiers.com/VLDCa9A2Kt4

rassembler les familles [XL-2013]

Macros et VBA Excel

Discussions similaires

Partager

Partager