Recherche et copie plusieurs mêmes occurrences

Le 25/04/2015 à 15:27

Bonjour à tous,

Je reviens avec mes problèmes en VBA.

Mon problème est le suivant:

En feuille 1, j'ai une référence, en feuille 2, j'ai des lignes avec ces références et des informations attachées.

Mon but est de copier en feuille 1 les informations de la feuille 2 en fonction des références.

Un exemple sera plus claire (je joins également un fichier excel avec des explications plus claires):

Feuille 1:

REF1

Feuille 2:

REF 1: Information, Information

REF 1: Information2 Information2

Je souhaiterais avoir le résultat suivant:

Feuille 1:

REF 1: Information Information

REF 1: information2 Information2

Au début je suis partie sur une recherchev en VBA, mais cela me copie juste la première occurrence:

DerLig = Range("C" & Rows.Count).End(xlUp).Row 'indique la derniere ligne de la colonne A
  DeFeuil2ig = Range("C" & Rows.Count).End(xlUp).Row 'indique la derniere ligne de la colonne A

    With Range("B4:B" & DerLig) 'Indique ou copier les données Attention lié au RC[-1]

    .Formula = "=VLOOKUP(RC[1],'rl'!C1:C2,2,FALSE)" ' recherchev vba avec RC[-1] indique la cellulbe B / 'tech'!C1:C2 / 2 la colonne ou le résultat sera affiche  ou chercher la valeur de manière relative VLookup("a", Sheets("Feuil1").Range("A2:C5"), 2, 0) a=> valeur recherché Sheets("Feuil1").Range("A2:C5") représente le tableau 2 colonne du résultat  0 valeur exacte
    On Error Resume Next
    .SpecialCells(xlCellTypeFormulas, xlErrors).ClearContents
    On Error GoTo 0
    .Value = .Value
  End With

J'ai réalisé avec l'aide d'exemples un autre code, mais celui-ci ne me copie que la dernière occurrence...

Private Sub CommandButton1_Click()
Dim i&
Dim T As Variant, D As Object

Set D = CreateObject("Scripting.Dictionary")
'Avec la feuille Feuil1
With Sheets("Feuil1")
    'On récupère toutes les valeurs de la plage A4 .Cells(4, 1)
    'jusqu'a la dernière cellule remplie en colonne 22 (V)
    T = .Range(.Cells(5, 1), .Cells(.Rows.Count, 23).End(3))
End With

'Pour chaque ligne i du tableau de valeurs
For i = LBound(T, 1) To UBound(T, 1)
    'La clé du dictionnaire est la valeur en colonne 20 (T) Ligne i
    ' L'item du dictionnaire est la valeur en colonne 22 (V) ligne i
    D(Trim(T(i, 1))) = T(i, 2)
Next i

'Avec la feuille Travail
With Sheets("Travail")
    ''On récupère toutes les valeurs de la plage B2 .Cells(2, 2)
    'jusqu'a la dernière cellule remplie en colonne B même ligne une colonne à droite (1, 2) soit C4492 dans l'exemple
   T = .Range(.Cells(4, 3), .Cells(.Rows.Count, 3).End(3)(1, 2))
End With
'on passe toutes les valeurs de la plage dans un tableau T
'pour chaque ligne i du tableau T
For i = LBound(T, 1) To UBound(T, 1)
    ' La valeur de la ligne i colonne 1 du tableau T
    'est égale à l'item du dictionnaire dont la clé est la valeur de la ligne i colonne 1 du tableau T
    T(i, 1) = D(Trim(T(i, 1)))
Next i
'On colle le tableau T ou on veux *************************************
Sheets("Travail").Range("$B$4").Resize(UBound(T, 1), 1) = T
End Sub

Bref, je suis un peu désespéré sur ce coup là, car je ne vois pas comment copier ces données attachées à une même référence.

En vous remerciant par avance pour votre aide

SIngertwist

PS: en pièce jointe, un fichier anonymisé.

Le 25/04/2015 à 17:18

Bonjour Singertwist, bonjour le forum,

Ton fichier modifié en pièce jointe avec le code ci-dessous :

Sub Macro1()
Dim O1 As Worksheet 'déclare la variable O1 (Onglet 1)
Dim O2 As Worksheet 'déclare la variable O2 (Onglet 2)
Dim TC As Variant 'déclare la variable TC (Tableau de Cellules)
Dim D As Object 'déclare la variable D (Dictionnaire)
Dim I As Integer 'déclare la variable I (Incrément)
Dim TMP As Variant 'déclare la variable TMP (tableau TeMPoraire)
Dim TL() As Variant 'déclare la variable TL (Tableau de Lignes)
Dim K As Integer 'déclare la variable K (incrément)
Dim PL As Integer 'déclare la variable PL (Première Ligne)
Dim J As Integer 'déclare la variable J (incrément)
Dim L As Byte 'déclare la variable L (incrément)

Set O1 = Sheets("Feuil1") 'définit l'onglet O1
Set O2 = Sheets("Feuil2") 'définit l'onglet O2
TC = O1.Range("B1").CurrentRegion 'définit le tableau de cellules TC (onglet O1)
Set D = CreateObject("Scripting.Dictionary") 'définit le dictionnaire D
For I = 4 To UBound(TC, 1) 'boucle sur toutes les lignes I du tableau de cellules TC (en partant de la quatrième)
    D(TC(I, 2)) = "" 'alimente le dictionnaire D avec la valeur en colonne 2 de TC (Référence)
Next I 'prochaine ligne de la boucle
TMP = D.keys 'récupère dans le tableau temporaire TMP la liste du dictionnaire D sans doublons
TC = O2.Range("A1").CurrentRegion 'redéfinit le tableau de cellules TC (onglet O2)
For I = 0 To UBound(TMP, 1) 'boucle 1 : sur tous les éléments du tableau temporaire TMP
    Erase TL 'efface le tableau TL
    K = 1 'initialise la variable K
    'définit la ligne PL de la première occurrence trouvée de l'élément TMP(I) dans la colonne 3 (=C) de l'onglet O1
    PL = O1.Columns(3).Find(TMP(I), O1.Range("C3"), xlValues, xlWhole).Row
    For J = 2 To UBound(TC, 1) 'boucle 2 : sur toutes les lignes J du tableau de cellules TC (en partant de la seconde)
        'condition : si la valeur en ligne J colonne 1 de TC (Référence magasin) est égale à l'élément TMP(I)
        If TC(J, 1) = TMP(I) Then
            ReDim Preserve TL(1 To 3, 1 To K) 'redimensionne le tableau TL (3 lignes, K colonnes)
            For L = 1 To 3 'boucle 3 : sur les 3 lignes de TL
                TL(L, K) = TC(J, L + 1) 'alimente la ligne de TL avec la colonne de TC (transposition)
            Next L 'prochaine ligne de la boucle 3
            K = K + 1 'incrémente K (ajoute une colonne à TL)
        End If 'fin de la condition
    Next J 'prochaine ligne de la boucle 2
    'si K est supérieur à 1, renvoie dans la cellule redimensionnée ligne PL, colonne 5 (=E) de l'onglet O1 le tableau TL transposé
    If K > 1 Then O1.Cells(PL, 5).Resize(UBound(TL, 2), UBound(TL, 1)).Value = Application.Transpose(TL)
Next I 'prochain élément de la boucle 1
End Sub
57singertwist-v01.xlsm (34.10 Ko)
Le 26/04/2015 à 11:20

Bonjour,

Merci beaucoup de ta réactivité. Cela fonctionne à merveille.

Cependant, j'ai une question. Je viens d'adapter mon fichier à mes besoins, mais dans mon fichier que j'utilise, une référence a 23 colonnes.

Or, dès que je veux copier 23 lignes, il y a une erreur dans le code.

J'ai remarqué que cette erreur se produit quand on passe de la colonne Z à la colonne AA.

Aurais-tu une solution sur ce point?

Je te mets si dessous le code que j'ai modifié:

Sub Bouton3_Cliquer()

Dim O1 As Worksheet 'déclare la variable O1 (Onglet 1)
Dim O2 As Worksheet 'déclare la variable O2 (Onglet 2)
Dim TC As Variant 'déclare la variable TC (Tableau de Cellules)
Dim D As Object 'déclare la variable D (Dictionnaire)
Dim I As Integer 'déclare la variable I (Incrément)
Dim TMP As Variant 'déclare la variable TMP (tableau TeMPoraire)
Dim TL() As Variant 'déclare la variable TL (Tableau de Lignes)
Dim K As Integer 'déclare la variable K (incrément)
Dim PL As Integer 'déclare la variable PL (Première Ligne)
Dim J As Integer 'déclare la variable J (incrément)
Dim L As Byte 'déclare la variable L (incrément)

Set O1 = Sheets("Feuil1") 'définit l'onglet O1
Set O2 = Sheets("evaluations") 'définit l'onglet O2
TC = O1.Range("B1").CurrentRegion 'définit le tableau de cellules TC (onglet O1)
Set D = CreateObject("Scripting.Dictionary") 'définit le dictionnaire D
For I = 4 To UBound(TC, 1) 'boucle sur toutes les lignes I du tableau de cellules TC (en partant de la quatrième)
   D(TC(I, 1)) = "" 'alimente le dictionnaire D avec la valeur en colonne 1 de TC (Référence)
Next I 'prochaine ligne de la boucle
TMP = D.keys 'récupère dans le tableau temporaire TMP la liste du dictionnaire D sans doublons
TC = O2.Range("A1").CurrentRegion 'redéfinit le tableau de cellules TC (onglet O2)
For I = 0 To UBound(TMP, 1) 'boucle 1 : sur tous les éléments du tableau temporaire TMP
   Erase TL 'efface le tableau TL
   K = 1 'initialise la variable K
   'définit la ligne PL de la première occurrence trouvée de l'élément TMP(I) dans la colonne 3 (=C) de l'onglet O1
   PL = O1.Columns(2).Find(TMP(I), O1.Range("B3"), xlValues, xlWhole).Row
    For J = 2 To UBound(TC, 1) 'boucle 2 : sur toutes les lignes J du tableau de cellules TC (en partant de la seconde)
       'condition : si la valeur en ligne J colonne 1 de TC (Référence magasin) est égale à l'élément TMP(I)
       If TC(J, 1) = TMP(I) Then
            ReDim Preserve TL(1 To 14, 1 To K) 'redimensionne le tableau TL (3 lignes, K colonnes)
           For L = 1 To 14 'boucle 3 : sur les 3 lignes de TL
               TL(L, K) = TC(J, L + 1) 'alimente la ligne de TL avec la colonne de TC (transposition)
           Next L 'prochaine ligne de la boucle 3
           K = K + 1 'incrémente K (ajoute une colonne à TL)
       End If 'fin de la condition
   Next J 'prochaine ligne de la boucle 2
   'si K est supérieur à 1, renvoie dans la cellule redimensionnée ligne PL, colonne 5 (=E) de l'onglet O1 le tableau TL transposé
   If K > 1 Then O1.Cells(PL, 16).Resize(UBound(TL, 2), UBound(TL, 1)).Value = Application.Transpose(TL)
Next I 'prochain élément de la boucle 1

End Sub

Et la ligne qui pose problème dans le débogueur d'Excel:

TL(L, K) = TC(J, L + 1)

L'erreur est la suivante: "L'indice n'appartient pas à la sélection"

En te remerciant par avance pour ton aide, et de ton aide déjà apportée

Passe un bon week end

Singertwist

Le 26/04/2015 à 13:08

Bonjour Singertwist, bonjour le forum,

Je ne comprends pas que l'on envoie pas directement un fichier exemple basé sur le fichier de travail. C'est une perte de temps inutile !...

Cela étant dit je ne comprends pas non plus pourquoi tu parle de 23 colonnes et dans le code tu écris : For L = 1 To 14 ???

En pièce jointe une version 2 adaptée mais comme je n'ai rien compris, pas sûr que ce soit cela que tu veux. Là, il suffit que le premier tableau ait deux colonnes de plus que le second (les 3 de Magasin en O1 moins une pour la Reférence magasine O2) pour que ça marche.

Sinon, envoie un bon exemple et te devrais avoir une bonne réponse !

40singertwist-v02.xlsm (35.59 Ko)
Le 26/04/2015 à 14:51

Tout d'abord merci pour ta réponse.

Oui je n'ai pas bien été claire dans mes propos...

Je te joins donc le fichier exemple en rapport avec le fichier travail. Désolé de ne pas t'avoir fourni un fichier complet, c'est juste que j'apprécie de travailler sur la solution qui est fournie, afin d'en comprendre les tenants et aboutissements. Et surtout d'être capable de modifier mon fichier le cas échéant.

Mais pour résumer,

  • En feuille 1: j'ai des informations avec des références (environ 3000 références uniques)
  • En feuille 2 (evaluations): j'ai aussi ces numéros de références, avec des informations attachées. Une référence peut être préssente plusieurs fois, mais avec des informations différentes.

Je souhaite donc obtenir en feuille 1, et pour chaque référence l'ensemble des informations attachées à une référence.

En te remerciant encore pour ton aide.

Singertwist

Le 26/04/2015 à 15:30

Bonjour Singertwist, bonjour le forum,

Ça n'a absolument plus rien à voir avec ton premier post !... Je passe la main...

Le 26/04/2015 à 15:52

Merci pour ton aide, finalement, en cherchant, j'ai réussi à adapter ton code.

Cela correspond donc à mes attentes. Je passe le sujet en résolu.

Rechercher des sujets similaires à "recherche copie memes occurrences"