Transformer et adapter INDEX/EQUIV en boucle vba [Résolu]

[Akhlan]

Bonjour,

sur ma feuille 1, j'ai ma colonne D avec des infos et une colonne E avec des équipements (non classés et avec redondance...)

sur ma feuille 5, j'ai une colonne F qui reprend les équipements de la feuille 1, colonne E et les classes par nombre et ayant auparavant effacer les doublons.

sur ma feuille 5, en colonne I, j'ai mis en place cette formule :

Code :

=INDEX('Feuille_1'!D:D; EQUIV(F2;'Feuille_1'E:E!;0))

ça fonctionne et ça me retourne bien l'info de la première infos trouvée en feuille 1 et correspondant à la cellule F de la feuille 5 (mais pas les suivantes...)

Je voudrais boucler cette formule en vba pour qu'elle me liste les une au dessous des autres les infos, qu'elle passe une ligne une fois que le mot recherché n'a plus de nouvelles infos et qu'elle continue ainsi de suite jusqu'à la fin de la colonne F...

J'espère que c'est clair car même moi, je trouve ça un peu compliqué à écrire ^^

D'avance merci

Akhlan

[Daniel.C]

Bonjour,

Je ne comprends pas ce bout de phrase :

et les classes par nombre

sinon, oui, c'est possible.

[Akhlan]

Merci Daniel.C,

sur la feuille 2, en colonne G, j'ai cette fonction

Code :

=NB.SI('Feuille_1'!E:E;F2)

ce qui me permet de classer la colonne F par nombre d’occurrence en jouant entre ces deux colonnes F et G

[gFZT82]

Bonjour,

Tu peux commencer avec ce code qui te permettra de trouver les informations associées aux équipements listés en feuille 5 (notée Feuille_5 dans le code, à adapter si nécessaire).

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
Sub Rechercher()
Dim Plage As Range, Cel As Range, C As Range
Dim LigneAjout As Long
Dim firstAddress As String
    Application.ScreenUpdating = False
    With Worksheets("Feuille_5")
        Set Plage = .Range("F2:F" & .Range("F" & Rows.Count).End(xlUp).Row)
        For Each Cel In Plage
            Set C = Worksheets("Feuille_1").Columns(5).Find(Cel, LookIn:=xlValues, lookat:=xlPart)
            If Not C Is Nothing Then
                firstAddress = C.Address
                Do
                    LigneAjout = .Range("I" & Rows.Count).End(xlUp).Row + 1
                    .Range("I" & LigneAjout).Value = C.Offset(0, -1)
                    Set C = Worksheets("Feuille_1").Columns(5).FindNext(C)
                Loop While Not C Is Nothing And C.Address <> firstAddress
            End If
        Next Cel
    End With
    Application.ScreenUpdating = True
    Set Plage = Nothing: Set Cel = Nothing: Set C = Nothing
End Sub

Cordialement.

[Akhlan]

Félicitation gFZT82, c'est un très bon premier jet

J'ai cependant une erreur à la fin du déroulement de la macro

Erreur d'exécution '13':
Incompatibilité de type

ma colonne (Feuille 1 / D) et ma colonne (Feuille 5 /J) sont de type Texte

Pour info, certaines cellules de la colonne (Feuille 1 / D) commencent par ====

Comme tu l'as peut-être remarqué, j'ai changé la colonne (Feuille 5 /I) par (Feuille 5 /J) car je voudrais que qu'en I, la valeur C de ta macro apparraisse à la première occurence trouvée (seulement une fois)

A voir plus tard si besoin... Je voudrai également que par "boucle C", si les informations issue de (Feuille 1 / D) sont identiques, qu'elles n'apparaissent qu'une fois mais qu'une cellule à droite d'elle (Feuille 5 / K) indique le nombre d'occurence (1 sera it aussi affiché si l'occurence est unique)

D'avance merci

[Akhlan]

j'ai avancé...

Code :

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
Sub Rechercher()
Dim Plage As Range, Cel As Range, C As Range
Dim LigneAjout As Long
Dim firstAddress As String
   Application.ScreenUpdating = False
   With Worksheets("Stats")
    Set Plage = .Range("F2:F" & .Range("F" & Rows.Count).End(xlUp).Row)
       For Each Cel In Plage
           Set C = Worksheets("Incidents mensuels").Columns(5).Find(Cel, LookIn:=xlValues, lookat:=xlPart)
           If Not C Is Nothing Then
               firstAddress = C.Address
               If LigneAjout = "0" Then LigneAjout = "1" '------------------------------------------------------------------
               Range("I" & LigneAjout + 1).Value = C '----------------------------------------------------------------------
               Do
                   LigneAjout = .Range("J" & Rows.Count).End(xlUp).Row + 1
                   .Range("J" & LigneAjout).Value = C.Offset(0, -1)
                   Set C = Worksheets("Incidents mensuels").Columns(5).FindNext(C)
               Loop While Not C Is Nothing And C.Address <> firstAddress
               LigneAjout = LigneAjout + 1 '--------------------------------------------------------------------------------
           End If
       Next Cel
   End With
   Application.ScreenUpdating = True
   Set Plage = Nothing: Set Cel = Nothing: Set C = Nothing
End Sub

les lignes que j'ai ajoutées place bien la valeur de C à la bonne place en I mais par contre, vu que LigneAjout est calculé dans la boucle

Code :

                   LigneAjout = .Range("J" & Rows.Count).End(xlUp).Row + 1

Je n'arrive pas à insérer une ligne vide dans cette colonne :-(

PS : J'ai compris d'ou venait mon message d'erreur, une des colonnes ou les données étaient prises contenait des valeurs #REF, du coup, en faisant une mise à jour "propre" de cette colonne avant de lancer la macro, plus de soucis...

PS2: Par contre c'est super super long, on est proche des 3 minutes pour lister 1521 lignes et mon fichier final mensuel contient environ 5000-6000 lignes :-(

[Daniel.C]

Essaie comme ceci :

Code :

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
Option Base 1
Sub test()
    Dim Tabl1, Tabl2, Equips, Res() As String, Ctr As Long
    Ctr = 0
    ReDim Res(1)
    With Sheets("Feuille_1")
        Tabl1 = .Range(.[D1], .Cells(.Rows.Count, 4).End(xlUp))
        Tabl2 = .Range(.[E1], .Cells(.Rows.Count, 5).End(xlUp))
    End With
    With Sheets("Feuille_5")
        Equips = .Range(.[F1], .Cells(.Rows.Count, 6).End(xlUp))
    End With
    For Each Item In Equips
        For i = 1 To UBound(Tabl2)
            If Tabl2(i, 1) = Item Then
                Ctr = Ctr + 1
                ReDim Preserve Res(Ctr)
                Res(Ctr) = Tabl1(i, 1)
            End If
        Next i
        Ctr = Ctr + 1
        ReDim Preserve Res(Ctr)
        Res(Ctr) = ""
    Next Item
    Sheets("Feuille_5").[J1].Resize(UBound(Res)) = Application.Transpose(Res)
End Sub

[Akhlan]

Merci Daniel,

quand je lance ta macro j'ai une pop-up

"Erreur définie par l'application ou par l'objet"

En regardant de plus près, l'erreur semble être liée au contenu de la cellule qui commence par =

Code :

====xxxxxxxxxxxxxxxxxxxx==== Trap yyyyyyyyyyyyyyyyyyyyyy

[Daniel.C]

Une cellule commençant par "=" est considérée comme contenant une formule. Regarde le classeur joint.
PS. Peux-tu mettre en PJ un classeur exemple ?

[Akhlan]

j'ai transposé les === sur ton fichier car je ne peux malheureusement pas fournir l'original...

J'ai également mis en forme le résultat que je souhaite obtenir sur la feuille 5

Merci

[Akhlan]

Une petite aide pour finaliser mon fichier ???

[Daniel.C]

J'ai dû mettre la plage de résultats au format texte. Je peux la remettre avec un format nombre (sauf les valeurs commençant par "=") si besoin est.

Option Base 1

Code :

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
Sub test()
    Dim Tabl1, Tabl2, Equips, Res() As String, Ctr As Long
    Ctr = 0
    ReDim Res(1)
    With Sheets("Feuille_1")
        Tabl1 = .Range(.[D2], .Cells(.Rows.Count, 4).End(xlUp))
        Tabl2 = .Range(.[E2], .Cells(.Rows.Count, 5).End(xlUp))
    End With
    With Sheets("Feuille_5")
        Equips = .Range(.[F2], .Cells(.Rows.Count, 6).End(xlUp))
    End With
    For Each Item In Equips
        For i = 1 To UBound(Tabl2)
            If Tabl2(i, 1) = Item Then
                Ctr = Ctr + 1
                ReDim Preserve Res(Ctr)
                Res(Ctr) = Tabl1(i, 1)
            End If
        Next i
        Ctr = Ctr + 1
        ReDim Preserve Res(Ctr)
        Res(Ctr) = ""
    Next Item
    Sheets("Feuille_5").[J2].Resize(UBound(Res)).NumberFormat = "@"
    Sheets("Feuille_5").[J2].Resize(UBound(Res)) = Application.Transpose(Res)
End Sub

[Akhlan]

nickel, plus de soucis de "===" , classement comme je le voulais, t'es un chef ^^

Code :

1
2
   Sheets("Stats").[J2].Resize(UBound(Res)).NumberFormat = "@"
   Sheets("Stats").[J2].Resize(UBound(Res)) = Application.Transpose(Res)

Ce code sert à ajuster la colonne J en largeur ? Si oui, ça ne semble pas fonctionner chez moi, mais bon, s'il n'y a plus que ça, ce n'est pas grave

Par contre, je souhaiterai vraiment que la colonne I se remplisse avec avec la valeur recherchée (une fois par boucle si possible)

et que la gestion des doublons soit traitée en K...

C'est possible ou ça devient trop complexe à mettre en place ?

Merci
Akhlan

[Daniel.C]

Non, la première ligne met les cellules au format texte et la seconde ajuste la plage devant recevoir le résultat à la taille de la variable Res. La variable est ensuite copiée dans cette plage.
Pour ajuster la largeur de la colonne, ajoute en dernière ligne :

Code :

Sheets("Stats").[J:J].AutoFit

[Akhlan]

J'ai réussit à ajouter le champ "item" une fois par boucle, l'inclure dans les table aurait sans doute été plus propre mais je ne sais pas faire....

Code :

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
   Dim Tabl1, Tabl2, Equips, Res() As String, Ctr As Long
   Ctr = 0
   ReDim Res(1)
   With Sheets("Incidents mensuels")
       Tabl1 = .Range(.[D2], .Cells(.Rows.Count, 4).End(xlUp))
       Tabl2 = .Range(.[E2], .Cells(.Rows.Count, 5).End(xlUp))
   End With
   With Sheets("Stats")
       Equips = .Range(.[F2], .Cells(.Rows.Count, 6).End(xlUp))
   End With
   For Each Item In Equips
    Range("I" & Ctr + 2).Value = Item
       For i = 1 To UBound(Tabl2)
           If Tabl2(i, 1) = Item Then
               Ctr = Ctr + 1
               ReDim Preserve Res(Ctr)
               Res(Ctr) = Tabl1(i, 1)
           End If
       Next i
       Ctr = Ctr + 1
       ReDim Preserve Res(Ctr)
       Res(Ctr) = ""
   Next Item
   Sheets("Stats").[J2].Resize(UBound(Res)).NumberFormat = "@"
   Sheets("Stats").[J2].Resize(UBound(Res)) = Application.Transpose(Res)
   Sheets("Stats").Columns("J:K").EntireColumn.AutoFit

Il me reste juste le problème de redondance de la colonne J mais là, ça va de loin dépasser mes compétences en VBA...

[Daniel.C]

Il me reste juste le problème de redondance de la colonne J mais là, ça va de loin dépasser mes compétences en VBA...

Tu veux supprimer les doublons ?

[Akhlan]

oui, je voudrai supprimer les doublons mais q'un compteur s'incrémente à la ligne équivalente (en colonne K) afin de remonter le nombre d’occurrence identique pour alléger la lecture...

Colonne I = item (une fois par boucle pour plus de clareté)
Colonne J = info remontée de la colonne D sans doublons
Colonne K = Nombre de répétition (le plus élevé en premier et 1 par défaut)

J'avais mis un exemple dans l'archive "Akhlan_2.7z"

[Daniel.C]

Ca modifie pas mal la macro. Je regarde dès que possible.

[Akhlan]

un grand merci

[Daniel.C]

Ca a l'air de fonctionner. Il y a peut-être du ménage à faire. Si tu veux des explications, n'hésite pas à les demander.

Code :

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
Sub test()
    Dim Tabl1, Tabl2, Equips, Res() As String, Ctr As Long
    Dim Tabl, Dico As Object 'table double entrée
    Dim ResEquip(), ResOccur() As Long, Plage As Range
    Set Dico = CreateObject("Scripting.Dictionary")
    Ctr = 0
    ReDim Res(3, 1)
    ReDim ResEquip(1)
    ReDim ResOccur(1)
    With Sheets("Feuille_1")
        Tabl1 = Application.Transpose(.Range(.[D2], .Cells(.Rows.Count, 4).End(xlUp)))
        Tabl2 = Application.Transpose(.Range(.[E2], .Cells(.Rows.Count, 5).End(xlUp)))
        For i = 1 To UBound(Tabl1)
            If Not Dico.exists(Tabl1(i) & "***" & Tabl2(i)) Then
                Dico.Add Tabl1(i) & "***" & Tabl2(i), Tabl1(i) & "***" & Tabl2(i)
            End If
        Next i
        For Each Item In Dico.items
            tablo = Split(Item, "***")
            Ctr = Ctr + 1
            ReDim Preserve Res(3, Ctr)
            Res(1, Ctr) = Item
            Res(2, Ctr) = tablo(1)
            Res(3, Ctr) = tablo(0)
        Next Item
    End With
    With Sheets("Feuille_5")
        .[H:K].ClearContents
        .[H2].Resize(UBound(Res, 2), 3).NumberFormat = "@"
        .[H2].Resize(UBound(Res, 2), 3) = Application.Transpose(Res)
        Set Plage = .Range(.[H2], .Cells(.Rows.Count, 10).End(xlUp))
        Plage.Sort key1:=.[I2], order1:=xlAscending, key2:=.[J2], order2:=xlAscending, Header:=xlNo
        Tabl = Application.Transpose(.Range(.[H2], .Cells(.Rows.Count, 8).End(xlUp)))
        ReDim ResOccur(Dico.Count)
        For i = 1 To UBound(Tabl1)
            Ctr = Application.Match(Tabl1(i) & "***" & Tabl2(i), Tabl, 0)
            ResOccur(Ctr) = ResOccur(Ctr) + 1
        Next
        .[K2].Resize(UBound(ResOccur)) = Application.Transpose(ResOccur)
        .[H:H].ClearContents
        Dim Final()
        ReDim Final(3, 1)
        Ctr = 0
        Tabl = Application.Transpose(.Range(.[I2], .Cells(.Rows.Count, 11).End(xlUp)))
        For i = 1 To UBound(Tabl, 2)
                Ctr = Ctr + 1
                ReDim Preserve Final(3, Ctr)
                Final(1, Ctr) = Tabl(1, i)
                Final(2, Ctr) = Tabl(2, i)
                Final(3, Ctr) = Tabl(3, i)
                If i < UBound(Tabl, 2) Then
                    If Tabl(1, i) <> Tabl(1, i + 1) Then
                        Ctr = Ctr + 1
                        ReDim Preserve Final(3, Ctr)
                    End If
                End If
        Next
        For i = UBound(Final, 2) To 2 Step -1
            If Final(1, i) = Final(1, i - 1) Then Final(1, i) = ""
        Next
        .[H:K].Clear
        .[I2].Resize(UBound(Final, 2), 2).NumberFormat = "@"
        .[I2].Resize(UBound(Final, 2), 3) = Application.Transpose(Final)
    End With
End Sub