Boucle Recherche colle sur un autre onglet

Question

Il y a année j'ai trouver sur la toile ce code qui fonctionne parfaitement pour une dizaine de référence ,aujourd'hui je me retrouve avec en moyenne 50 référence à copiée coller. je souhaite que le code aille chercher le mot clef dans la feuille décompte fournisseur pour déclenché la recherche, puis une fois la recherche finit il passe a ligne suivante je tente d'adapté le mot clef pour qu'il aille parcourir la liste définit mes rien ne fonctionne merci pour votre aide Sub Recherche_colle() Dim MotCle Dim i As Byte Dim C As Range Dim a As String Dim Ligne As Long Sheets("Extracteur").Select 'On définit les mots clés entre les cotes MotCle = Array("LIONOR", "") On Error Resume Next 'On effectue la recherche de chaque mot clé dans la colonne A de la Feuil1 For i = 0 To UBound(MotCle) Do Set C = Worksheets("Extracteur").Columns(11).Find(MotCle(i), LookIn:=xlValues, LookAt:=xlPart) 'Si le mot clé n'est pas trouvé If Not C Is Nothing Then 'On définit le nom de la feuille où sera effectuée la copie a = "Feuil" & (i + 2) With Worksheets(a) 'On définit la ligne où sera effectué le collage Ligne = .Range("A" & Rows.Count).End(xlUp).Row + 1 'On effectue le copier / coller C.EntireRow.Copy .Range("A" & Ligne) 'On supprime la ligne dans la Feuil1 C.EntireRow.Delete Range("A1").Select ActiveSheet.UsedRange End With End If Loop While Not C Is Nothing Next i Sheets("Extracteur").Select Range("a1").Select Set plage = Nothing End Sub...

ThauThème · Accepted Answer

Bonjour le fil, bonjour le forum,

En pièce jointe ton fichier modifié et le code ci-dessous :

Sub Recherche_colle()
Dim OE As Worksheet 'déclare la variable OE (Onglet Extracteur)
Dim TV As Variant 'déclare la variable TV (Tableau des Valeurs)
Dim D As Object 'déclare la variable D (Dictionnaire)
Dim I As Integer 'déclare la variable I (Incrément)
Dim J As Integer 'déclare la variable J (incrément)
Dim K As Integer 'déclare la variable K (incrément)
Dim L As Byte 'déclare la variable L (incrément)
Dim TMP As Variant 'déclare la variable TMP (tableau TEMPoraire)
Dim OD As Worksheet 'déclare la variable OD (Onglet Destination)
Dim TL() As Variant 'déclare la variable TL (Tableau des Lignes)

Application.ScreenUpdating = False 'masque les rafraîchissements d'écran
Set OE = Worksheets("Extracteur") 'définit l'onglet OE
TV = OE.Range("A1").CurrentRegion 'définit le tableau des valeurs TV
Set D = CreateObject("Scripting.Dictionary") 'définit le dictionnaire D
For I = 2 To UBound(TV, 1) 'boucle sur toutes les lignes I du tableau des valeurs TV (en partant de la seconde)
    If TV(I, 11) <> "" Then D(TV(I, 11)) = "" 'alimente le dictionnaire D avec les données en colonne 11 de TV (le fournisseur)
Next I 'prochaine ligne de la boucle
TMP = D.Keys 'récupère dans le tableau temporaire TMP la liste des éléments du dictionnaire D sans doublon
For J = 0 To UBound(TMP) 'boucle 1 : sur tous les éléments J du tableau temporaire TMP
    Erase TL: K = 0 'efface le tableau TL, réinitialise la variable K
    On Error Resume Next 'gestion des erreurs (en cas d'erreur passe à la ligne suivante)
    Set OD = Worksheets(TMP(J)) 'définit l'onglet OD (génère une erreur si cet onglet n'existe pas)
    If Err > 0 Then 'condition : si une erreur a été générée
        Err.Clear 'supprime l'erreur
        Worksheets.Add after:=Sheets(Sheets.Count) 'ajoute un onglet vierge en dernière position
        Set OD = ActiveSheet 'définit l'onglet OD
        OD.Name = TMP(J) 'renomme l'onglet OD
    End If 'fin de la condition
    On Error GoTo 0 'annule la gestion des erreurs
    OD.Cells.ClearContents 'efface les cellules de l'onglet OD (au cas ou l'onglet existait déjà)
    For I = 2 To UBound(TV, 1) 'boucle 2 : sur toutes les lignes I du tableau des valeurs TV (en partant de la seconde)
        If TV(I, 11) <> "" And TV(I, 11) = TMP(J) Then 'condition : si la donnée ligne I colonne 11 de TV n'est pas vide et est égale à l'élément J du taleau temporaire TMP
            K = K + 1 'incrémente K
            ReDim Preserve TL(1 To UBound(TV, 2), 1 To K) 'redimensionne le tableau des lignes TL (autant de lignes que TV a de colonnes, K colonnes)
            For L = 1 To UBound(TV, 2) 'boucle 3 : sur toutes les colonnes L du tableau des valeurs TV
                TL(L, K) = TV(I, L) 'récupère dans la ligne L de TL la donnée en colonne L de TV (=> Transposition)
            Next L 'prochaine colonne de la boucle 3
        End If 'fin de la condition
    Next I 'prochaine ligne de la boucle 2
    If K > 0 Then 'condition : si K est supérieure à zéro
        OD.Range("A1").Resize(1, UBound(TV, 2)).Value = Application.Index(TV, 1) 'renvoie la première ligne de TV dans la cellule A1 redimensionnée de l'onglet OD
        OD.Range("A2").Resize(K, UBound(TV, 2)).Value = Application.Transpose(TL) 'renvoie le tableau TL transposé dans la cellule A2 redimensionnée de l'onglet OD
    End If 'fin de la condition
Next J 'prochain élément de la boucle 1
Application.ScreenUpdating = False 'affiche les rafraîchissements d'écran
MsgBox "Données traitées !" 'message
OE.Activate 'active l'onglet OE
End Sub

9pyro-ep-v01.xlsm (191.25 Ko)

3GB · Answer

S'il s'agit uniquement de prendre la liste des mots clés sur la feuille, voici un essai avec une plage hypothétique nommée "ListeMotsCles" : Sub Recherche_colle() Dim C As Range Dim a As String Dim Ligne As Long MotCle = application.transpose(Range("ListeMotsCles")) '&lt;&lt;&lt;&lt; base 1 With Sheets("Extracteur") For i = lbound(MotCle) To UBound(MotCle) Do Set C = .Columns(11).Find(MotCle(i), LookIn:=xlValues, LookAt:=xlPart) If Not C Is Nothing Then a = "Feuil" & (i + 1) '&lt;&lt;&lt;&lt; i&nbsp;+ 2 devient i + 1 car base 1 With Worksheets(a) Ligne = .Range("A" & .Rows.Count).End(xlUp).Row + 1 C.EntireRow.Copy .Range("A" & Ligne) C.EntireRow.Delete End With End If Loop While Not C Is Nothing Next i End with End Sub Cdlt...