Discussion :

[Yanns09]

Bonjour je suis entrain de développer une macro pour effectuer une recherche sous EXCEL.
Je dispose de données qui me servent de références. Les références peuvent être jumelées entre elles, je m'explique: Si "Voiture A" est ma référence 1 et "Rouge" ma référence 2 je peux tout aussi avoir "Voiture A" comme référence 1 et "Vert" comme référence 2.
J'ai mis au point un petit programme qui "fonctionne" mais ne me donne pas tout le temps les bonnes données. Les première, cinquième et sixième données correspondent à celles des références entrées, mais pour les deuxièmes troisièmes et quatrième, les données sont interverties. Quelqu'un aurait-il une idée ? J'ai essayé de voir où se trouve le problème mais selon moi ça devrait me donner les bonnes valeurs .
Quand je limite mon tableau à 3 valeurs, le programme fonctionne; dès que j'augmente le nombre d'informations à traiter les résultats obtenus ne sont plus tous bons.

Je vous mets en annexe mon code ainsi que le fichier Excel correspondant.

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
Sub Recherche()
 
    '====================================================================================
    '                               Déclaration des variables
    '====================================================================================
 
    Dim i As Integer
    Dim n As Integer
    Dim Drawing_Req() As Variant
    Dim Refs() As Variant
 
    Sheets("Temp").Select
    n = 4
 
    Drawing_Req = Range("A4:A9").Value
    Refs = Range("C4:C9").Value
 
    '====================================================================================
    '               Recherche des données grâces aux références
    '====================================================================================
 
    Sheets("Spectre").Select
 
    For i = 20 To 33 ' Zone de recherche des références et requirements
        For j = LBound(Drawing_Req, 1) To UBound(Drawing_Req)
            If Drawing_Req(j, 1) = Cells(i, 3).Value Then
                If Refs(j, 1) = Cells(i, 5) Then
                    Range("I" & i, "O" & i).Copy ThisWorkbook.Sheets("Temp").Range("E" & n)
                    n = n + 1
                End If
            End If
        Next j
    Next i
 
 
    '====================================================================================
    '     Suppressions des cellules vides 
    '====================================================================================
 
    ' Suppression Cellules vides
    Sheets("Temp").Select
    Range("E4", "L" & (n - 1)).Select
    Selection.SpecialCells(xlCellTypeBlanks).Delete Shift:=xlToLeft
 
End Sub

[Invité]

Bonjour,

A tester :

Nb : Certaines couleurs contiennent un caractère blanc à la fin, cela ne peut pas matcher. Solution, corriger ou utiliser des Trim comme dans le code ci-dessous

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
66
67
68
69
70
71
72
73
74
 
Option Explicit
 
 
Sub Recherche()
 
    '====================================================================================
    '                               Déclaration des variables
    '====================================================================================
 
Dim ShTemp As Worksheet, ShSpectre As Worksheet
Dim LigneSpectre As Long, PremiereLigneSpectre As Long, DerniereLigneSpectre As Long
Dim PremiereLigneTemp As Long, DerniereLigneTemp As Long, ColObjet As Long, ColCouleur As Long, ColResultat As Long, DerniereColonneTemp As Long
Dim AireTemp As Range, CelluleTemp As Range
 
    On Error GoTo Fin
 
    Set ShTemp = Sheets("Temp")
    Set ShSpectre = Sheets("Spectre")
 
    With ShTemp
 
         PremiereLigneTemp = 4
         ColObjet = 1
         ColCouleur = 3
         ColResultat = 5
         DerniereLigneTemp = .Cells(.Rows.Count, ColObjet).End(xlUp).Row
 
         If DerniereLigneTemp < PremiereLigneTemp Then GoTo Fin
 
         Set AireTemp = .Range(.Cells(PremiereLigneTemp, ColObjet), .Cells(DerniereLigneTemp, ColObjet))
 
    End With
 
    '====================================================================================
    '               Recherche des données grâces aux références
    '====================================================================================
 
    With ShSpectre
 
         PremiereLigneSpectre = 20
         DerniereLigneSpectre = 33
 
         For Each CelluleTemp In AireTemp
              For LigneSpectre = PremiereLigneSpectre To DerniereLigneSpectre ' Zone de recherche des références et requirements
                  If Trim(CelluleTemp) = Trim(.Cells(LigneSpectre, 3)) And Trim(CelluleTemp.Offset(0, ColCouleur - ColObjet)) = Trim(.Cells(LigneSpectre, 5)) Then
                     .Range(.Cells(LigneSpectre, 9), .Cells(LigneSpectre, 15)).Copy Destination:=CelluleTemp.Offset(0, ColResultat - ColObjet)
                  End If
              Next LigneSpectre
        Next CelluleTemp
 
    End With
 
 
    '====================================================================================
    '     Suppression des cellules vides et déplacement dans la feuille principale
    '====================================================================================
 
    With ShTemp
         DerniereColonneTemp = 13 ' .UsedRange.SpecialCells(xlCellTypeLastCell).Column
         With .Range(AireTemp.Offset(0, ColResultat - ColObjet), AireTemp.Offset(0, DerniereColonneTemp - ColObjet))
              .SpecialCells(xlCellTypeBlanks).Delete Shift:=xlToLeft
         End With
    End With
 
    GoTo Fin
 
Fin:
 
    Set AireTemp = Nothing
    Set ShTemp = Nothing
    Set ShSpectre = Nothing
 
End Sub

[Yanns09]

Bonjour,
J'ai testé ton programme et il marche, je l'ai adapté pour qu'il fonctionne de manière globale avec ma feuille de travail et c'est tout simplement sublime.
Mille mercis.

Même si en soit je me demande toujours ce qui cloche dans mon programme , c'est bizarre qu'il donne de bonnes valeurs pour certaines et pour d'autres les intervertisse.
Mais bon pour le moment, j'utiliserai le tien pour avancer dans mon travail, et si jamais je trouve la coquille dans le mien, je vous tiens au courant.
Sur ce, je marque le poste comme résolu.
A tester :

Nb : Certaines couleurs contiennent un caractère blanc à la fin, cela ne peut pas matcher. Solution, corriger ou utiliser des Trim comme dans le code ci-dessous

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
66
67
68
69
70
71
72
73
74
 
Option Explicit
 
 
Sub Recherche()
 
    '====================================================================================
    '                               Déclaration des variables
    '====================================================================================
 
Dim ShTemp As Worksheet, ShSpectre As Worksheet
Dim LigneSpectre As Long, PremiereLigneSpectre As Long, DerniereLigneSpectre As Long
Dim PremiereLigneTemp As Long, DerniereLigneTemp As Long, ColObjet As Long, ColCouleur As Long, ColResultat As Long, DerniereColonneTemp As Long
Dim AireTemp As Range, CelluleTemp As Range
 
    On Error GoTo Fin
 
    Set ShTemp = Sheets("Temp")
    Set ShSpectre = Sheets("Spectre")
 
    With ShTemp
 
         PremiereLigneTemp = 4
         ColObjet = 1
         ColCouleur = 3
         ColResultat = 5
         DerniereLigneTemp = .Cells(.Rows.Count, ColObjet).End(xlUp).Row
 
         If DerniereLigneTemp < PremiereLigneTemp Then GoTo Fin
 
         Set AireTemp = .Range(.Cells(PremiereLigneTemp, ColObjet), .Cells(DerniereLigneTemp, ColObjet))
 
    End With
 
    '====================================================================================
    '               Recherche des données grâces aux références
    '====================================================================================
 
    With ShSpectre
 
         PremiereLigneSpectre = 20
         DerniereLigneSpectre = 33
 
         For Each CelluleTemp In AireTemp
              For LigneSpectre = PremiereLigneSpectre To DerniereLigneSpectre ' Zone de recherche des références et requirements
                  If Trim(CelluleTemp) = Trim(.Cells(LigneSpectre, 3)) And Trim(CelluleTemp.Offset(0, ColCouleur - ColObjet)) = Trim(.Cells(LigneSpectre, 5)) Then
                     .Range(.Cells(LigneSpectre, 9), .Cells(LigneSpectre, 15)).Copy Destination:=CelluleTemp.Offset(0, ColResultat - ColObjet)
                  End If
              Next LigneSpectre
        Next CelluleTemp
 
    End With
 
 
    '====================================================================================
    '     Suppression des cellules vides et déplacement dans la feuille principale
    '====================================================================================
 
    With ShTemp
         DerniereColonneTemp = 13 ' .UsedRange.SpecialCells(xlCellTypeLastCell).Column
         With .Range(AireTemp.Offset(0, ColResultat - ColObjet), AireTemp.Offset(0, DerniereColonneTemp - ColObjet))
              .SpecialCells(xlCellTypeBlanks).Delete Shift:=xlToLeft
         End With
    End With
 
    GoTo Fin
 
Fin:
 
    Set AireTemp = Nothing
    Set ShTemp = Nothing
    Set ShSpectre = Nothing
 
End Sub