Transformer et adapter INDEX/EQUIV en boucle vba

**Akhlan** · 16/02/2013, 12h04

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 :

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

=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** · 16/02/2013, 13h36

Bonjour,

Je ne comprends pas ce bout de phrase :

et les classes par nombre

sinon, oui, c'est possible.

**Akhlan** · 17/02/2013, 08h04

Merci Daniel.C,

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

Code :

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

=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** · 17/02/2013, 10h11

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 :

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
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** · 17/02/2013, 11h47

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** · 18/02/2013, 10h01

j'ai avancé...

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
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 :

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

                   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** · 18/02/2013, 11h22

Essaie comme 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
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** · 18/02/2013, 14h46

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 :

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

====xxxxxxxxxxxxxxxxxxxx==== Trap yyyyyyyyyyyyyyyyyyyyyy

**Daniel.C** · 18/02/2013, 15h30

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** · 18/02/2013, 17h21

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** · 20/02/2013, 09h39

Une petite aide pour finaliser mon fichier ???

**Daniel.C** · 20/02/2013, 11h43

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 :

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
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** · 20/02/2013, 12h27

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

Code :

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

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** · 20/02/2013, 14h10

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 :

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

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

**Akhlan** · 20/02/2013, 14h34

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 :

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
   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** · 20/02/2013, 15h22

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** · 20/02/2013, 16h16

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** · 20/02/2013, 18h00

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

**Akhlan** · 20/02/2013, 18h14

un grand merci

**Daniel.C** · 21/02/2013, 14h22

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 :

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
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

Transformer et adapter INDEX/EQUIV en boucle vba

Macros et VBA Excel

Discussions similaires

Partager

Partager