Bonsoir,
une version "100%" VBA avec l''aide d'un dictionnaire afin de travailler sans doublon au niveau de la liste de la colonne unique du fichier B, et en plus l'instruction "Existe" du dictionnaire est plus rapide que le "Find".
Donc les valeur du fichier A, sont mises dans un tableau VBA, les valeurs du fichier B sont mises dans un dictionnaire.
Chaque valeur du fichier A lors de la boucle sur la taille de ce tableau sont "splitées" avec la virgule, ce qui nous donne un tableau des valeur contenues dans la cellule.
On test si chacune de ces valeurs existent ou pas dans le dictionnaire.
Si elle existe on l'inscrit dans le tableau de sortie TabloS.
On crée ensuite une valeur string "Temp" qui est la concaténation de ce tableau de sortie avec les virgules.
La valeur de la colonne A est ensuite inscrite dans un tableau résultat, et la valeur Temp est inscrite également sur ce tableau. On boucle sur la valeur de cellule du fichier A suivante.
à la fin on inscrit le tableau résultat sur la feuille 2 à partir de la cellule A2.
Le code :
Option Explicit
Sub TrouveEtEfface()
Application.ScreenUpdating = False
Dim MonDico As New Scripting.Dictionary
Dim Tablo, TabloS(), Tab_Résultat()
Dim ColonneA, ColonneB As Range, I, J, K, Trouve As Range, Tmp As Variant
Dim Temp As String, Cpt, Cpt2
ColonneA = ActiveSheet.Range("B2:B8178").Value
For I = 2 To 40120
If Not MonDico.Exists(Workbooks("b-type.xlsb").Sheets("Feuil1").Cells(I, 1)) Then
MonDico.Add "_" & Workbooks("b-type.xlsb").Sheets("Feuil1").Cells(I, 1), Workbooks("b-type.xlsb").Sheets("Feuil1").Cells(I, 1)
End If
Next I
Cpt = 0
Cpt2 = 0
For J = 0 To Ubound(ColonneA,1)-1
Tablo = Split(ColonneA(J + 1, 1), ",")
For K = 0 To UBound(Tablo)
If MonDico.Exists("_" & Evaluate(Tablo(K) * 1)) Then
ReDim Preserve TabloS(Cpt + 1)
TabloS(Cpt) = Tablo(K)
Cpt = Cpt + 1
End If
Next K
On Error Resume Next
Tmp = UBound(TabloS)
On Error GoTo 0
If Not IsEmpty(Tmp) Then
For I = 0 To UBound(TabloS) - 1
Temp = Temp & TabloS(I) & ","
Next I
Temp = Mid(Temp, 1, Len(Temp) - 1)
Else
Temp = ""
End If
ReDim Preserve Tab_Résultat(1, Cpt2 + 1)
Tab_Résultat(0, Cpt2) = Feuil1.Cells(J + 2, 1).Value
Tab_Résultat(1, Cpt2) = Temp
Erase TabloS
Erase Tablo
Cpt = 0
Cpt2 = Cpt2 + 1
Temp = ""
Tmp = Empty
Next J
Feuil2.Activate
Range("A2").Resize(UBound(Tab_Résultat, 2), 2) = Application.Transpose(Tab_Résultat)
End Sub
Il peut, peut-être plus simple...
Le fichier :
Attention, pour l'analyse complète il faut changer le "compteur" final de la boucle J et il faut que les deux fichiers se trouvent au même endroit et qu'il soient ouverts.
Il y a aussi un test sur le fait que le TabloS soit vide ou pas afin d'éviter une erreur de code, et si le cas se présente alors une cellule vide (Temp="") sera inscrite en face de l'intitulé de la colonne A.
Il faut aussi activer le module VBA Microsoft Scripting Runtime, pour le dictionnaire :
@ bientôt
LouReeD