Tableau : restitution différence 2 listes (VBA) : idée + précision sur execution code svp

zebanx

XLDnaute Accro
Bonsoir à tous,

Pour poursuivre sur un fil fort intéressant traité cet apm par Robert / Pierrejean

https://www.excel-downloads.com/thr...ipement-manquant-par-nom-et-profils.20026132/

une variante proposée ci-joint pour déterminer entre une liste complète (catégorie) et une liste du disponible (listing) les éléments qui manqueraient à placer sur un tableau complémentaire.

Le code ci-dessous fonctionne (il me semble!), mais si je pars de la sheet ("manque"), il me squeeze des données : pourquoi svp ?
Et si vous avez d'autres propositions, alternatives ou de simplification de ce code, je vous en remercie par avance.

Bonne soirée à tous
zebanx

Code:
Sub difference()
Dim tr As Variant
Dim tc(), tl()
Dim shc As Worksheet, shl As Worksheet, shm As Worksheet
Dim n%, m%, q%, r%
 
Set shc = Sheets("categorie")
Set shl = Sheets("listing")
Set shm = Sheets("manque")
    
tc = shc.Range("a2:g" & Cells(Rows.Count, 1).End(3).Row).Value2
tl = shl.Range("a2:h" & Cells(Rows.Count, 1).End(3).Row).Value2
ReDim tr(1 To UBound(tl, 1), 1 To 8)
 
'On Error Resume Next
'--- boucle sur chaque valeur du tableau listing
For n = LBound(tl, 1) To UBound(tl, 1)
For m = LBound(tc, 1) To UBound(tc, 1)
w = 2
     
    If tc(m, 1) = tl(n, 2) Then
      b = b + 1
      tr(b, 1) = tl(n, 1): tr(b, 2) = tl(n, 2)
            For q = 2 To 7
            For r = 3 To 8
                If tc(m, q) = tl(n, r) Then GoTo suite:  '---si l'article est retrouvée dans la base sur la ligne de la catégorie
                Next r
                w = w + 1
                tr(b, w) = tc(m, q)
suite:
        Next q
    End If
Next m
Next n
      
shm.[A2].Resize(UBound(tl, 1), 8) = tr

End Sub
 

Pièces jointes

  • liste.xls
    45 KB · Affichages: 29

Discussions similaires

Réponses
16
Affichages
2 K
Réponses
5
Affichages
422
Réponses
6
Affichages
445

Statistiques des forums

Discussions
314 653
Messages
2 111 579
Membres
111 207
dernier inscrit
max008