Bonjour à tous,

Je poste sur le forum afin d'obtenir de l'aide concernant un problème sur lequel je me casse la tête.

J'ai réalisé le code suivant qui me permet de parcourir une plage composée de kits.
A chaque nouvelle valeur (chaque kit), j'effectue une recherche dans une autre feuille afin d'identifier les pièces qui composent ce kit.
Un kit peut avoir plusieurs pièces, de ce fait, je réalise une boucle "Do ...Loop While". Tant que la valeur du kit de la ligne actuelle est identique à la valeur du kit de la ligne suivante, on poursuit le parcours des pièces.
Ensuite je colle dans une feuille "Recap'", le kit avec chacune de ses pièces.

Le problème est que je parcours des plages assez grandes (jusqu'à 1000 kits différents), ce qui fait que ma feuille récap dépasse facilement les 10 000 lignes.
Et parcourir ces lignes est long avec ce code:

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
Dim Kit, DescriptionKit, Pieces, Outils As String
Dim i As Integer
Dim cell, x, Plage As Range
 
'''''''''''''''''''''''Récupération des données''''''''''''''''''''''''''''''
Application.ScreenUpdating = False
 
With Sheets("Principale")
i = 2
.Activate
Fin = .Range("A65536").End(xlUp).Row
Set Plage = Sheets("Principale").Range(Cells(1, 1), Cells(Fin, 1))
 
    For Each cell In Plage
    Kit = cell
    LigneDesc = cell.Row
    DescriptionKit = .Cells(LigneDesc, 2)
 
        With Sheets("FeuillePiece").[A1:Z65536]
        Set x = .Find(What:=Kit, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByColumns)
        j = 0
            If Not x Is Nothing Then
            Ligne = x.Row
                Do
                Pieces = .Cells(Ligne, 3)
                Sheets("Recap").Range("A" & i + j) = Kit
                Sheets("Recap").Range("B" & i + j) = DescriptionKit
                Sheets("Recap").Range("C" & i + j) = "-"                
                Sheets("Recap").Range("D" & i + j) = Pieces
                Ligne = Ligne + 1
                    If Sheets("FeuillePiece").Cells((Ligne - 1), 1).Value = Sheets("FeuillePiece").Cells(Ligne, 1).Value And Sheets("FeuillePiece").Cells(Ligne, 1).Value <> "" Then
                    j = j + 1
                    End If
                Loop While Sheets("FeuillePiece").Cells((Ligne - 1), 1).Value = Sheets("FeuillePiece").Cells(Ligne, 1).Value And Sheets("FeuillePiece").Cells(Ligne, 1).Value <> ""
                i = i + j
                Set x = Nothing
                i = i + 1
            Else
            End If
        End With
	Next
End With
End Sub
De ce fait, j'ai tenté de rajouter des variables tableau, mais je ne maitrise pas trop ces variables et j'ai le sentiment de ne pas prendre le bon chemin, d'où ma venue ici.
Voici le code que j'ai fait et qui n'est pas terminé (et donc non fructueux):

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
Sub Test()
 
Dim Kit, DescriptionKit, Pieces, Outils As StringDim i As Integer
Dim cell, x, Plage As Range
Dim Tableau(), data As Variant
Dim cpt1 As Long, cpt2 As Long
 
'''''''''''''''''''''''Récupération des données''''''''''''''''''''''''''''''
Application.ScreenUpdating = False
 
With Sheets("Principale")
i = 2
.Activate
Fin = .Range("A65536").End(xlUp).Row
Set Plage = Sheets("Principale").Range(Cells(1, 1), Cells(Fin, 1))
 
data = .[A1].Resize(Cells(Rows.Count, 1).End(xlUp).Row + 1, 5).Value
ReDim Tableau(1 To UBound(data, 1), 1 To UBound(data, 2))
	For lig = 1 To UBound(data)
    Kit = data(lig, 1)
    LigneDesc = lig
    DescriptionKit = data(LigneDesc,2)
        With Sheets("FeuillePiece").[A1:Z65536]
        Set x = .Find(What:=Kit, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByColumns)
        j = 0
            If Not x Is Nothing Then
            Ligne = x.Row
                Do
                Pieces = .Cells(Ligne, 3)
                Sheets("Recap").Range("A" & i + j) = Kit
                Sheets("Recap").Range("B" & i + j) = DescriptionKit
                Sheets("Recap").Range("C" & i + j) = "-"                
                Sheets("Recap").Range("D" & i + j) = Pieces
                Ligne = Ligne + 1
                    If Sheets("FeuillePiece").Cells((Ligne - 1), 1).Value = Sheets("FeuillePiece").Cells(Ligne, 1).Value And Sheets("FeuillePiece").Cells(Ligne, 1).Value <> "" Then
                    j = j + 1
                    End If
                Loop While Sheets("FeuillePiece").Cells((Ligne - 1), 1).Value = Sheets("FeuillePiece").Cells(Ligne, 1).Value And Sheets("FeuillePiece").Cells(Ligne, 1).Value <> ""
                i = i + j
                Set x = Nothing
                i = i + 1
            Else
            End If
        End With
    Next lig
End With
End Sub
Si vous pouviez m'aider à simplifier tout ça, je vous en serai très reconnaissant !