Utilisation de Index et Match en recherche multicritères en VBA

Version imprimable

Voir 40 message(s) de cette discussion en une page

1 pièce(s) jointe(s)

Utilisation de Index et Match en recherche multicritères en VBA

Bonjour à tous,

Je me résouds finalement à poser la question sur le forum car je bloque sur ce problème depuis deux ou trois jours sans résultats.
Je voudrais récupérer des commentaires qui se trouvent dans la colonne "Comments" d'un tableau TAB1 dans une feuille X et les mettre dans
une colonne "comments" d'un tableau TAB2 se trouvant dans une autre feuille Y. Je veux récupérer chaque commentaire en tenant compte du nom de la ressource et du projet sur lequel elle travaille. Sachant qu'une même ressource peut travailler sur deux ou n projets avec des commentaires différents associés.
Pour illustrer mon propos ci-joint un extrait de mes tableaux (en pièces jointes) et du code VBA utilisé.
Nb: les variables plages (définies en Range) étant les colones (Resource, Title, Comments) des tableaux, TAB1 et TAB2. La boucle For Each avec resName= chaque nom de la colonne Resource de TAB2
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 iLoop = 1 For Each resName In srcPlage projName = localwSh.Cells(iLoop + 1, colProj).Value On Error GoTo Err_Mngt retIndex = WorksheetFunction.Index(comtPlage, WorksheetFunction.Match(resName, refPlage, 0) * _ WorksheetFunction.Match(projName, titlePlage, 0) - 1) If Not IsError(retIndex) Then 'set the comment Name in the comment Column destPlage.Cells(iLoop + 1, 1) = retIndex Else GoTo Err_Mngt End If
Merci pour vos éclairages.

cdt
Clem256

Citation:

Envoyé par clem256

Bonjour,

A adapter et à tester :

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
 
Option Explicit
 
Sub RecupererLesCommentairesDansTab2(ByVal AireTableau1 As Range, ByVal AireTableau2 As Range)
 
Dim CelluleTableau1 As Range, CelluleTableau2 As Range
 
    For Each CelluleTableau2 In AireTableau2
        For Each CelluleTableau1 In AireTableau1
            If CelluleTableau1 & CelluleTableau1.Offset(0, 1) = CelluleTableau2 & CelluleTableau2.Offset(0, 1) Then
                CelluleTableau2.Offset(0, 2) = CelluleTableau1.Offset(0, 2)
            End If
        Next CelluleTableau1
    Next CelluleTableau2
 
End Sub
 
Sub LancerRecupererLesCommentairesDansTab2()
 
Dim ZoneTab1 As Range, ZoneTab2 As Range
 
    On Error GoTo Fin
 
    With ActiveSheet
 
         Set ZoneTab1 = .Range("AireTab1")
         Set ZoneTab2 = .Range("AireTab2")
 
         RecupererLesCommentairesDansTab2 ZoneTab1, ZoneTab2
 
    End With
 
    GoTo Fin
 
Fin:
 
    Set ZoneTab1 = Nothing
    Set ZoneTab2 = Nothing
 
End Sub

04/04/2018, 10h50
clem256

Bonjour Eric

Merci pour votre réponse rapide et votre proposition. Je n'ai pas encore essayé, mais je le ferai asap. Une remarque: je comprends que vous me déconseillez donc d'utiliser Index/match dans cette recherche?
Avec "With ActiveSheet", cela ne suppose-t-il pas que les deux tableaux TAB1 et TAB2 soient dans la même feuille? Or dans ma situation, ils se trouvent dans des feuilles différentes. Etant peu familier du "With", je suppose qu'il faudra que j'adapte cette portion de code?

Cdt

clem256

Bonjour,

Citation:

Une remarque: je comprends que vous me déconseillez donc d'utiliser Index/match dans cette recherche?

Je propose plutôt une méthode avec laquelle je suis habitué.

Citation:

Avec "With ActiveSheet", cela ne suppose-t-il pas que les deux tableaux TAB1 et TAB2 soient dans la même feuille? Or dans ma situation, ils se trouvent dans des feuilles différentes., je suppose qu'il faudra que j'adapte cette portion de code?

Il suffit d'indiquer les onglets pour chaque aire.
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 Sub LancerRecupererLesCommentairesDansTab2() Dim ZoneTab1 As Range, ZoneTab2 As Range On Error GoTo Fin Set ZoneTab1 = Sheets("XXXX").Range("AireTab1") Set ZoneTab2 = Sheets("YYYY").Range("AireTab2") RecupererLesCommentairesDansTab2 ZoneTab1, ZoneTab2 GoTo Fin Fin: Set ZoneTab1 = Nothing Set ZoneTab2 = Nothing End Sub

04/04/2018, 22h25
clem256

Eric,

J'ai donc adapté le code proposé à mon application. Seulement je n'ai pas le résultat escompté. Pour le moment aucun commentaire n'est enregistré dans la colonne "Comments" de Tab2, comme si aucune correspondance n'était trouvée. Mais peut-être est-ce de ma faute. En fait les tableaux Tab1 et Tab2 de mon extrait ne sont pas exactement identiques à ceux que je teste. Les colonnes Resources, Title et Comments ne sont pas adjacentes dans mes tableaux réels. Est-ce que cela pose des problème avec l'utilisation de la propriété offset? Ce sont respectivement les colonnes 1, 3 et 11 des tableaux réels.
De plus pour éviter de parcourir le millions de ligne de la feuille (ce qui prend un certain temps, ne puis-je pas limiter les aires aux "CurrentRegion" avant d'appeler la fonction de récupération des commentaires?

Merci

Clem256
04/04/2018, 23h39
Promethee25

Bonjour,

Pourquoi passes-tu par du VBA?
Tu pourrais très bien passer par une formule Excel puis écraser par valeur si c'est pour un changement à faire une seule fois.

La formule matricielle en C4 serait:

Code:

=INDEX($C$17:$C$25, MATCH(A4 & "@" & B4, $A$17:$A$25 & "@" & $B$17:$B$25, 0))

à valider par Ctrl+Maj+Entrée
Le '@' permet de bien séparer le contenu des deux colonnes dans lesquelles il faut regarder (par sécurité).
Encapsule dans un SIERREUR selon ton besoin:

Code:

=IFERROR(INDEX($C$17:$C$25,MATCH(A4&"@"&B4,$A$17:$A$25&"@"&$B$17:$B$25,0)),"")

Sinon tu peux adapter cette formule à ton code mais je ne sais pas si WorksheetFunction.Match aura un comportement automatiquement matriciel; c'est à vérifier.

Citation:

Envoyé par clem256

Est-ce que cela pose des problème avec l'utilisation de la propriété offset? Ce sont respectivement les colonnes 1, 3 et 11 des tableaux réels.
De plus pour éviter de parcourir le millions de ligne de la feuille (ce qui prend un certain temps, ne puis-je pas limiter les aires aux "CurrentRegion" avant d'appeler la fonction de récupération des commentaires?

La réponse est Oui. Il faut de plus, modifier la définition des aires pour la source et la cible.

A tester :

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
 
Option Explicit
 
Sub RecupererLesCommentairesDansTab2(ByVal AireTableau1 As Range, ByVal AireTableau2 As Range)
 
Dim CelluleTableau1 As Range, CelluleTableau2 As Range
 
    For Each CelluleTableau2 In AireTableau2
        For Each CelluleTableau1 In AireTableau1
            If CelluleTableau1 & CelluleTableau1.Offset(0, 2) = CelluleTableau2 & CelluleTableau2.Offset(0, 2) Then
                CelluleTableau2.Offset(0, 10) = CelluleTableau1.Offset(0, 10)
            End If
        Next CelluleTableau1
    Next CelluleTableau2
 
End Sub
 
Sub LancerRecupererLesCommentairesDansTab2()
 
Dim ZoneTab1 As Range, ZoneTab2 As Range
Dim LigneTitreTab1 As Long, DerniereLigneTab1 As Long, LigneTitreTab2 As Long, DerniereLigneTab2 As Long
 
    On Error GoTo Fin
 
    With Sheets("Source Tab1")
         LigneTitreTab1 = 1
         DerniereLigneTab1 = .UsedRange.SpecialCells(xlCellTypeLastCell).Row
         Set ZoneTab1 = .Range(.Cells(LigneTitreTab1 + 1, 1), .Cells(DerniereLigneTab1, 1))
    End With
 
    With Sheets("Cible Tab2")
         LigneTitreTab2 = 1
         DerniereLigneTab2 = .UsedRange.SpecialCells(xlCellTypeLastCell).Row
         Set ZoneTab2 = .Range(.Cells(LigneTitreTab2 + 1, 1), .Cells(DerniereLigneTab2, 1))
    End With
 
    RecupererLesCommentairesDansTab2 ZoneTab1, ZoneTab2
 
    GoTo Fin
 
Fin:
 
    Set ZoneTab1 = Nothing
    Set ZoneTab2 = Nothing
 
End Sub

Bonjour Promethee25 : Toutes les solutions sont les bienvenues et si une solution est possible sans VBA, alors tu as raison, il vaut mieux l'utiliser. Cependant, chacun répond avec ce qu'il maîtrise, l'important restant l'efficacité.

05/04/2018, 06h36
Promethee25

Bonjour Eric,

Bien sûr, pas de souci.
Ma question ne s'adressait pas à toi mais à Clem256; n'y vois aucune critique de ma part mais juste la volonté de comprendre les raisons du choix qu'il a fait par rapport à son besoin qui, peut-être mais sans l'affirmer, pourrait être résolu sans VBA.

Edit: en me relisant, c'est vrai que mon post n'était pas suffisamment clair et prêtait à interprétation, désolé.
05/04/2018, 10h43
clem256

Bonjour

Merci à vous deux, Eric et Promethee25 pour vos conseils et propositions. J'avais continué à travailler hier soir, for tard, sur le sujet et j'ai réussi à faire fonctionner le Code VBA avant les dernières indications d'Eric que je vais tester. je pense qu'il me faut approfondir l'utilisation de Range et offset. J'ai deux remarques: à l'exécution de la double boucle For Each..Next, l'écran est bloqué pendant presque 2 minutes avant d'avoir de nouveau la main sous l'application Excel (les tableaux n'ont que 220 lignes environ..). Y-a-t-il une instruction particulière à insérer pour éviter cela? Quand j'ai la main mes ascenceurs, vertical et horizontal, ont disparu da la feuille destination, mais j'ai les commentaires:lol:

@Promethee25: j'utilse VBA parce que l'application en développement est en VBA. J'avais déjà utilisé l'expression Matricielle de Index/Match sous Excel et cela fonctionnait bien. Merci pour le tip pour "@" je ne connaissais pas.

Clem256

Citation:

Envoyé par clem256

à l'exécution de la double boucle For Each..Next, l'écran est bloqué pendant presque 2 minutes avant d'avoir de nouveau la main sous l'application Excel (les tableaux n'ont que 220 lignes environ..). Y-a-t-il une instruction particulière à insérer pour éviter cela?

Voir ce post lenteur-execution-code

S'il y a beaucoup de formules, le principe est de bloquer le recalcul provisoirement et de bloquer le rafraîchissement de l'écran. Il suffit d'encadrer le code avec :
Code:

1 2 3 4 5 6 Application.ScreenUpdating = False Application.Calculation = xlCalculationManual ' ..... Application.Calculation = xlCalculationAutomatic Application.ScreenUpdating = True
Quant à :

Citation:

Quand j'ai la main mes ascenceurs, vertical et horizontal, ont disparu da la feuille destination, mais j'ai les commentaires

Je ne vois pas d'où cela peut venir. Il faudrait voir ton code.

Bonjour Eric

Pour les ascenceurs on oublie.
Quelle portion de code doit être encadrée par ces instructions:
Code:

1 2 3 4 5 6 Application.ScreenUpdating = False Application.Calculation = xlCalculationManual ' .....Boucle For Each Application.Calculation = xlCalculationAutomatic Application.ScreenUpdating = True
car en encadrant la boucle For Each externe avec elles, cela ne fonctionne pas mieux.
Merci
Clem256

Citation:

Envoyé par clem256

Bonjour,

Par exemple 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
27
28
29
30
31
32
33
34
35
36
37
 
 
Sub LancerRecupererLesCommentairesDansTab2()
 
Dim ZoneTab1 As Range, ZoneTab2 As Range
Dim LigneTitreTab1 As Long, DerniereLigneTab1 As Long, LigneTitreTab2 As Long, DerniereLigneTab2 As Long
 
    On Error GoTo Fin
 
    With Sheets("Source Tab1")
         LigneTitreTab1 = 1
         DerniereLigneTab1 = .UsedRange.SpecialCells(xlCellTypeLastCell).Row
         Set ZoneTab1 = .Range(.Cells(LigneTitreTab1 + 1, 1), .Cells(DerniereLigneTab1, 1))
    End With
 
    With Sheets("Cible Tab2")
         LigneTitreTab2 = 1
         DerniereLigneTab2 = .UsedRange.SpecialCells(xlCellTypeLastCell).Row
         Set ZoneTab2 = .Range(.Cells(LigneTitreTab2 + 1, 1), .Cells(DerniereLigneTab2, 1))
    End With
 
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
 
    RecupererLesCommentairesDansTab2 ZoneTab1, ZoneTab2
 
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
 
    GoTo Fin
 
Fin:
 
    Set ZoneTab1 = Nothing
    Set ZoneTab2 = Nothing
 
End Sub

Combien y a-t-il de lignes dans les boucles ?

10/04/2018, 09h35
clem256

Bonjour

Il y a 220 lignes dans l'un et 230 lignes dans l'autre.

Clem256
10/04/2018, 09h43
Invité

Citation:

Envoyé par clem256

Bonjour,

C'est rien du tout. Tu as toujours ces problèmes de lenteur malgré ces lignes ?
10/04/2018, 16h01
clem256

Bonjour

oui j'ai regardé ce matin. le problème de blocage de l'écran pour l'application Excel existe toujours. Il doit y avaoir un truc trop évident que j'ai oublié. Mais sinon le reste fonctione très bien. Il ne me reste qu'à faire une gestion d'erreur plus fine pour sécuriser le fonctionnement. Merci pour tes conseils et propositions de code. Et aussi merci à Promethee-25.

Clem256

Citation:

Envoyé par clem256

As-tu des macros événementielles dans ton fichier ou dans les fichiers impactés par ton code ?

Si oui, il te faut les neutraliser provisoirement :

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
 
Sub LancerRecupererLesCommentairesDansTab2()
 
Dim ZoneTab1 As Range, ZoneTab2 As Range
Dim LigneTitreTab1 As Long, DerniereLigneTab1 As Long, LigneTitreTab2 As Long, DerniereLigneTab2 As Long
 
    On Error GoTo Fin
 
    Application.EnableEvents = False
 
    With Sheets("Source Tab1")
         LigneTitreTab1 = 1
         DerniereLigneTab1 = .UsedRange.SpecialCells(xlCellTypeLastCell).Row
         Set ZoneTab1 = .Range(.Cells(LigneTitreTab1 + 1, 1), .Cells(DerniereLigneTab1, 1))
    End With
 
    With Sheets("Cible Tab2")
         LigneTitreTab2 = 1
         DerniereLigneTab2 = .UsedRange.SpecialCells(xlCellTypeLastCell).Row
         Set ZoneTab2 = .Range(.Cells(LigneTitreTab2 + 1, 1), .Cells(DerniereLigneTab2, 1))
    End With
 
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
 
 
 
    RecupererLesCommentairesDansTab2 ZoneTab1, ZoneTab2
 
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
 
    Application.EnableEvents = True
 
    GoTo Fin
 
Fin:
 
    Set ZoneTab1 = Nothing
    Set ZoneTab2 = Nothing
 
End Sub

12/04/2018, 10h27
clem256

Bonjour
Non je ne pense pas. Aucune instruction (pour le moment) pour gestion des événements. Tout est séquentiel dans le code qui de plus ne traite que des données se trouvant dans ce même fichier.
12/04/2018, 10h35
Invité

Citation:

Envoyé par clem256

Bonjour,

Alors je ne vois pas.

Non mais je vais me plonger un peu dans la relecture du code. L'important était que je récupère les commentaires et c'est fait. Donc je vais considérer le point comme résolu. Juste pour info, il faut dire que mes tableaux "Source Tab1e et "Cible Tab2" sont respectivement des variables définies par le Name Manger Excel come
='Last Report-View'!$B:$L et =shReportTest!$B:$L

Voici le code utilisé à partir de tes suggestions (j'ai déplacé le retour en mode calcul automatique sous l'étiquette Fin, car quand j'avais une erreur dans les fonctions, l'option calcul manuel restait pour le fichier).
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 On Error GoTo Fin Sheets(prevReport).Activate lnFin = Range("AireTab1").Cells(Rows.Count, 1).End(xlUp).Row lastCol = Range("AireTab1").Columns.Count Set ZoneTab1 = Range("AireTab1").Range(Cells(2, 1), Cells(lnFin, lastCol)) 'Debug.Print "Nbre Colonnes ZoneTab1 = " & ZoneTab1.Columns.Count Sheets(shTest).Activate lnFin = Range("AireTab2").Cells(Rows.Count, 1).End(xlUp).Row Set ZoneTab2 = Range("AireTab2").Range(Cells(2, 1), Cells(lnFin, lastCol)) 'Debug.Print "Nbre Colonnes ZoneTab2 = " & ZoneTab2.Columns.Count Application.ScreenUpdating = False Application.Calculation = xlCalculationManual RecupererLesCommentairesDansTab2 ZoneTab1, ZoneTab2
Merci.

12/04/2018, 11h10
Invité
Citation:

Envoyé par clem256

Ton problème vient des aires que tu as prises en compte, c'est énorme. Il faut que tu limites ton nombre de lignes.
Code:

1 2 ='Last Report-View'!$B:$L et =shReportTest!$B:$L
Pour récupérer ta dernière ligne,
Code:

1 2 3 4 With Sheets("XXXX") DerniereLigne = .UsedRange.SpecialCells(xlCellTypeLastCell).Row End With

Voir 40 message(s) de cette discussion en une page