Récupérer plusieurs lignes d'une table (array)

Version imprimable

Bonjour à tous,

J'ai un problème que je n'arrive pas à résoudre.

Mon objectif est trouver des lignes spécifiques dans un tableau de 10 colonne [A ->J] avec 15000 lignes. Ces lignes spécifiques doivent vérifier une condition en colonne B et une condition en colonne C.

Le première étape que j'ai fait dans le sub est de ranger mes données dans une table : (tab1 est donc la table avec les données du tableau)
Code:

1 2 3 4 5 6 Dim tab1() Workbooks.("Fichier").Worksheets("Feuille").Activate Nb_ligne_tab1 = (Range("A" & Rows.Count).End(x1Up).Row) Nb_colonne_tab1 =Cells(1,Colums.Count).End(x1Left).Column tab1 = Range (Cells (1,1),Cells(Nb_ligne_tab1,NB_colonne_tab1))
Ensuite je cherche les valeurs : (tab2 est la table de résultat à 2 lignes et 1 colonne, on pourra incrémenter d'autre colonne)
Code:

1 2 3 4 5 6 For p = 1 to nb_ligne_tab1 If Cstr("tartempion4") = Cstr(tab1(p,2)) And Cstr("bidule01") = Cstr(tab1(p,3)) Then tab2(1,1)=tab1(p,4) tab2(2,1)=tab1(p,5) End if Next
Ce code marche mais mon soucis est enfaite qu'il y a plusieurs résultats et que mon code s'arrête au premier qu'il trouve.
Pour trouver tous les résultats, j'ai essayé les méthodes avec For Each, Do Loop, Filter, Match mais rien ne fonctionne donc j'espère que vous allez pouvoir m'aider et j'espère avoir été clair pour expliquer mon problème :)

Merci beaucoup !!

03/11/2021, 07h27
jurassic pork

2 pièce(s) jointe(s)

hello,

Citation:

Envoyé par Jonhy7

J'ai un problème que je n'arrive pas à résoudre.
Mon objectif est trouver des lignes spécifiques dans un tableau de 10 colonne [A ->J] avec 15000 lignes. Ces lignes spécifiques doivent vérifier une condition en colonne B et une condition en colonne C.

je ne connais le but final de ton code mais pourquoi n'utilises-tu pas un filtre pour ne récupérer que certaines lignes de ta feuille avec certaines conditions.
Même sans utiliser de VBA on peut faire la manipulation que tu veux faire :
Exemple :
feuille de départ :
Pièce jointe 607913

1 - Sélectionner toutes les cellules que l'on veut filtrer (avec la ligne d'entête).
2 - Dans l'onglet Données cliquer sur Filtrer. Des boutons avec flèches vers le bas apparaissent dans la ligne d'entête.
3 - Dans les colonnes voulues , sélectionner le critère de filtre.
4 - Et voilà on ne voit plus que les lignes avec les critères demandés :
Pièce jointe 607915

Ami calmant, J.P
03/11/2021, 09h46
Jonhy7

Bonjour jurassic pork et je te remercie pour la réponse.

Cependant, cette méthode je la connais et ne peux pas être applicable dans mon cas car je dois automatiser le processus. J'ai simplifier le problème pour que ce soit compréhensible mais le problème est bien de trouver différentes lignes dans la table avec deux conditions spécifiques.

Je ne peux pas passer par la feuille Excel car il faut répéter l'opération pour des milliers de couples et retourner des valeurs et je suis obliger de passer par des tables (array) pour stocker la data car mes fichiers excels sont très grands (50000 lignes).

Salut
Une piste en VBA
L'idée est de parcourir chaque cellule (c) dans ton tableau de données (rng), d'y trouver les 2 valeurs chercher et ensuite, je suppose, recopier la liste des valeurs trouvées dans la même feuille de calculs. Pour ma part, à partir de la cellule A40

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
Sub CopieDynamique()
Dim xlwbk As Workbook, xlwbs As Worksheet
Dim c As Range, rng As Range
Dim myArray() As Variant
Dim i As Long
 
Set xlwbk = ThisWorkbook
Set xlwbs = Worksheets("Feuille")
Set rng = xlwbs.Range(Cells(2, 1), Cells(Range("A" & Rows.Count).End(xlUp).Row, Cells(2, Columns.Count).End(xlToLeft).Column))
 
xlwbs.Range("A40:A" & Range("A" & Rows.Count).End(xlUp).Row).ClearContents
 
For Each c In rng
    If c.Value = "tartempion4" Or c.Value = "bidule01" Then
        ReDim Preserve myArray(i)
        myArray(i) = c.Value
        i = i + 1
    End If
Next c
For i = LBound(myArray) To UBound(myArray)
    Cells(40 + i, 1) = myArray(i)
Next i
End Sub

Bonjour hyperion13, merci pour ta réponse.

L'idée est pas mal et j'avais essayé quelque chose comme ça mais ça n'avait pas marché. D'ailleurs tu n'as pas mis la plage dans une table, moi j'avais mis dans une table et j'avais faie un For Each, peut être pour ça que ça n'avait pas fonctionnée..

Je vous montre ce que j'ai fait :

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
Sub CopieDynamique()
 
'la première étape est de mettre les données dans une table
 
Dim tab_info()
 
Workbooks("Source").Worksheets("Infos").Activate
Nb_Ligne_Infos = (Range("A" & Rows.Count).End(xlUp).Row)
Nb_Colonne_Infos = Cells(1, Columns.Count).End(xlToLeft).Column
tab_infos = Range(Cells(1, 1), Cells(Nb_Ligne_so1, Nb_Colonne_so1))
 
Dim b As Variant
Dim v as Integer
Dim tab_intern(2,1)
 
v = 1
 
'on parcourt chaque ligne de la table
 
For Each b In tab_infos
 
    'on vérifie si on trouve des correspondances dans les colonnes 5 et 1
 
    If CStr(tab_infos(b, 5)) = CStr("1234") And CStr(tab_infos(b, 1)) = CStr("6547")  Then
 
        'si oui, on stocke le résultat des colonnes 2 et 3 dans la table tab_intern (j'utiles une table pour stocker mes résultats car donc mon cas réel c'est 
        plus pratique)
 
        ReDim tab_intern(2, v)
 
        tab_intern(1, v) = tab_infos(b, 2)
        tab_intern(2, v) = tab_infos(b, 3)
 
 
        ' Je copie les données sur une feuille excel pour vérifier
 
        Workbooks("Source").Worksheets("TEST").Cells(v, 1).Value = tab_intern(1, v)
        Workbooks("Source").Worksheets("TEST").Cells(v, 2).Value = tab_intern(2, v)
 
        'on incrémente tab_intern s'il y a plusieurs lignes dans tab_infos qui correspond à notre requête
 
        v = v + 1
 
    End If
 
Next b
 
End Sub

Voilà j'ai fais ça mais ca ne fonctionne pas, ca me mets une erreur de incompatibilité pour ma ligne avec le If.

L'erreur est que le For Each ne parcourt pas la table, la variable b prend la première valeur du tableau et donc le reste du programme ne marche plus.
Est-ce qu'il y a une solution pour parcourir une table ?

Bonjour Johny7

Tu n'étais pas loin, voilà qui marche

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
Sub CopieDynamique()
 
'la première étape est de mettre les données dans une table
 
Dim tab_infos()
Dim nb_ligne_Infos, Nb_Colonne_Infos, Lig
Dim wshSrc As Worksheet
Dim wshDst As Worksheet
 
Set wshDst = thisWorkbook.Worksheets("TEST")
 
Set wshSrc = thisWorkbook.Worksheets("Infos")  '.Activate
nb_ligne_Infos = wshSrc.Range("A" & wshSrc.Rows.count).End(xlUp).row
Nb_Colonne_Infos = wshSrc.Cells(1, wshSrc.Columns.count).End(xlToLeft).Column
tab_infos = wshSrc.Range(wshSrc.Cells(1, 1), wshSrc.Cells(nb_ligne_Infos, Nb_Colonne_Infos))
 
Dim b As Variant
Dim v As Integer
Dim tab_intern()
 
v = 1
 
'on parcourt chaque ligne de la table
 
For Lig = 1 To nb_ligne_Infos
 
    'on vérifie si on trouve des correspondances dans les colonnes 5 et 1
 
    If CStr(tab_infos(Lig, 5)) = CStr("1234") And CStr(tab_infos(Lig, 1)) = CStr("6547") Then
 
        'si oui, on stocke le résultat des colonnes 2 et 3 dans la table tab_intern (j'utilise une table pour stocker mes résultats car donc mon cas réel c'est plus pratique)
 
        ReDim Preserve tab_intern(2, v)
 
        tab_intern(1, v) = tab_infos(Lig, 2)
        tab_intern(2, v) = tab_infos(Lig, 3)
 
        ' Je copie les données sur une feuille excel pour vérifier
 
        wshDst.Cells(v, 1).value = tab_intern(1, v)
        wshDst.Cells(v, 2).value = tab_intern(2, v)
 
        'on incrémente tab_intern s'il y a plusieurs lignes dans tab_infos qui correspond à notre requête
        v = v + 1
    End If
Next 'Lig
End Sub

2 pièce(s) jointe(s)

hello,
voici une autre version du code à fraflt69 où j'ai fait quelques modifications :
1 - Dans le tableau tab_intern il y avait une colonne en trop (0) qui ne servait pas. Nouveau code :

Code:

ReDim Preserve tab_intern(1 To 2, 1 To v)

2 - On commençait le balayage à partir de la ligne 1 qui est la ligne d'entête -> On commence à la ligne 2
3 - Les données et les colonnes ne correspondaient pas aux données à Jonhy7 -> Mise en concordance.
4 - La recopie du tableau tab_intern dans la feuille de vérification se faisait ligne par ligne -> Utilisation de la fonction
Array2Range pour remplir la feuille en une seule fois.
5 - Ajout d'une mesure du temps d'exécution de la macro par Timer.
Voici le code modifié :

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
Sub CopieDynamique()
'la première étape est de mettre les données dans une table
Dim tab_infos()
Dim nb_ligne_Infos, Nb_Colonne_Infos, Lig
Dim wshSrc As Worksheet
Dim wshDst As Worksheet
Dim t1, t2 As Double
t1 = Timer
Set wshDst = ThisWorkbook.Worksheets("Test")
 
Set wshSrc = ThisWorkbook.Worksheets("Feuille")  '.Activate
nb_ligne_Infos = wshSrc.Range("A" & wshSrc.Rows.Count).End(xlUp).Row
Nb_Colonne_Infos = wshSrc.Cells(1, wshSrc.Columns.Count).End(xlToLeft).Column
tab_infos = wshSrc.Range(wshSrc.Cells(2, 1), wshSrc.Cells(nb_ligne_Infos, Nb_Colonne_Infos))
 
Dim b As Variant
Dim v As Integer
Dim tab_intern()
 
v = 1
 
'on parcourt chaque ligne de la table
 
For Lig = 1 To nb_ligne_Infos - 1
 
    'on vérifie si on trouve des correspondances dans les colonnes 5 et 1
 
    If CStr(tab_infos(Lig, 2)) = "tartempion4" And CStr(tab_infos(Lig, 3)) = "bidule01" Then
        'si oui, on stocke le résultat des colonnes 4 et 5 dans la table tab_intern (j'utilise une table pour stocker mes résultats car donc mon cas réel c'est plus pratique)
 
        ReDim Preserve tab_intern(1 To 2, 1 To v)
 
        tab_intern(1, v) = tab_infos(Lig, 4)
        tab_intern(2, v) = tab_infos(Lig, 5)
 
        ' Je copie les données sur une feuille excel pour vérifier
 
        'wshDst.Cells(v, 1).Value = tab_intern(1, v)
        'wshDst.Cells(v, 2).Value = tab_intern(2, v)
 
        'on incrémente tab_intern s'il y a plusieurs lignes dans tab_infos qui correspond à notre requête
        v = v + 1
    End If
Next 'Lig
 ' Je copie les données sur une feuille excel pour vérifier
Array2Range tab_intern, wshDst.Range("A1"), True
t2 = Timer
Debug.Print "Temps écoulé :", CStr(t2 - t1) + " s"
End Sub
 
Sub Array2Range(arr, destTL As Range, transpose As Boolean)
    If transpose Then arr = Application.WorksheetFunction.transpose(arr)
    'dumps  (1D/2D) onto a sheet where [destTL] is the top-left output cell.
    destTL.Resize(UBound(arr, 1) - LBound(arr, 1) + 1, _
        UBound(arr, 2) - LBound(arr, 2) + 1) = arr
End Sub

6 - Ajout d'une procédure de remplissage alétoire des colonnes B et C dont voici le code :
Voici la procédure de remplissage :

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
Sub RemplissageAlea()
Dim tab_infos()
Dim nb_ligne_Infos, Nb_Colonne_Infos, Lig
Dim wshSrc As Worksheet
Dim wshDst As Worksheet
Dim Tartempion, Bidule
Dim randArrIndex As Integer
Set wshDst = ThisWorkbook.Worksheets("Test")
Set wshSrc = ThisWorkbook.Worksheets("Feuille")  '.Activate
nb_ligne_Infos = wshSrc.Range("A" & wshSrc.Rows.Count).End(xlUp).Row
Nb_Colonne_Infos = wshSrc.Cells(1, wshSrc.Columns.Count).End(xlToLeft).Column
tab_infos = wshSrc.Range(wshSrc.Cells(2, 1), wshSrc.Cells(nb_ligne_Infos, Nb_Colonne_Infos))
v = 1
Tartempion = Array("", "tartempion1", "tartempion3", "tartempion4")
Bidule = Array("", "bidule01", "bidule02", "bidule03")
'on parcourt chaque ligne de la table
For Lig = 1 To nb_ligne_Infos - 1
    randArrIndex = Int(4 * Rnd)
    tab_infos(v, 2) = Tartempion(randArrIndex)
    randArrIndex = Int(4 * Rnd)
    tab_infos(v, 3) = Bidule(randArrIndex)
    v = v + 1
Next 'Lig
End Sub

Voici les dernières lignes des feuilles Feuille et Test :

Pièce jointe 608004--------->Pièce jointe 608005

Voici les résultats sur mon ordinateur pour une feuille de 16000 lignes avec 1056 lignes qui correspondent au critère.
temps écoulé : 110 ms en utilisant la copie ligne par ligne dans la feuille de destination.
temps écoulé : 47 ms en utilisant la fonction Array2Range
temps écoulé : 31 ms sans utiliser la feuille de destination.

Ami calmant, J.P

06/11/2021, 21h59
Jonhy7

Merci beaucoup, j'ai pu résoudre mon soucis grâce à votre aide !!

À bientôt !