XL 2010 Boucle for next macro vba

[lolobala]

Bonjour à tous,

Je suis en train de faire une macro vb et je rencontre un problème que je n'arrive pas à résoudre.
Je ne suis pas un pro dans le domaine alors le code en pièce jointe risque de vous paraître un peu tordu.

Voici ce que la macro est censé faire :
J'ai une liste de recherche dans l'onglet 2, je recherche les valeurs dans l'onglet BD. Je copie les plages et colle dans un dernier onglet.
J'utilise pour ça des boucles imbriquées et le résultat n'est pas bon. J'ai l'impression que le code relis les premières valeurs cherchées....trop de boucles peut être

Dans l'onglet en rouge vous trouverez le résultat que je souhaiterai obtenir.
Merci pour votre aide, bonne journée

Laurent

 

[vgendron]

Bonjour

une fois que tu as copié ta plage.. il faut la vider pour la prochaine itération de boucle
sinon. effectivement, elle est copiée plusieurs fois..

 

[lolobala]

Bonjour

une fois que tu as copié ta plage.. il faut la vider pour la prochaine itération de boucle
sinon. effectivement, elle est copiée plusieurs fois..

Bonjour,
Oui c'est ce que je me suis dis alors j'ai essayé de faire un Set Plage = Nothing mais ça ne fonctionne pas
Je ne dois pas l'utiliser comme il faut.

 

[vgendron]

une question sur le fonctionnemnt de ta macro

tu commences par remplacer dans la colonne C de la feuille BD, tous les codes SE fictif (colonne A) par les codes PF ou SE Père (colonne B) listés dans la feuille Liste_Recherche ?

ensuite tu récupères les lignes avec les nouveaux codes pour les mettre dans la feuille "Nouvelle Gamme" ?

on est d'accord que les changements de code sont irréversibles car appliqués directment dans la BD

une remarque générale, tu as définis des f1 f2 f3.. sans jamais les utiliser par la suite dans ton code

 

[lolobala]

une question sur le fonctionnemnt de ta macro

tu commences par remplacer dans la colonne C de la feuille BD, tous les codes SE fictif (colonne A) par les codes PF ou SE Père (colonne B) listés dans la feuille Liste_Recherche ? Oui

ensuite tu récupères les lignes avec les nouveaux codes pour les mettre dans la feuille "Nouvelle Gamme" ? Oui

on est d'accord que les changements de code sont irréversibles car appliqués directment dans la BD oui c'est assez dangereux je sais.

une remarque générale, tu as définis des f1 f2 f3.. sans jamais les utiliser par la suite dans ton code Pas partout effectivement

 

[fredl]

pour ce faire tu as 2 lignes à déplacer :
voir code
Fred

 

[fanch55]

Bonjour,
si j'ai bien analysé le résultat attendu, c'est un cas type de filtre élaboré :
modifier la colonne B de la feuille "liste_recherche" :

Puis exécuter le code ci-dessous:

Sub Filter()
With Worksheets("Nouvelle_gamme")
    .Activate
    .Cells.Clear
    Set lr = Worksheets("Liste_recherche").Range("B" & Rows.Count).End(xlUp)
    Worksheets("BD").[$a:$ad].AdvancedFilter _
        CriteriaRange:=Worksheets("Liste_recherche").Range("$b1:" & lr.Address), _
        Action:=xlFilterCopy, _
        CopyToRange:=.[$a1]
        
    Set lr = Range("C" & Rows.Count).End(xlUp)
    With .Sort
        .SortFields.Add2 Key:=Range("C2:" & lr.Address), _
            SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
        .SetRange Range("A:AD")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
        
End With

End Sub

 

[vgendron]

une solution en PJ, peut etre un peu plus simple..??
voir macro _2

 

[fredl]

Sub Nouvelle_gamme()
Dim ValCherch
Dim ValRemplace
Dim Plage, Desti As Range

'Stop rafraichissement ecran
Application.ScreenUpdating = False
Dim f1, f2, f3 As Worksheet
Set f1 = Sheets("BD"): Set f2 = Sheets("Nouvelle_gamme"): Set f3 = Sheets("Liste_recherche")
f1.Select

'Définition de la dernière ligne de l'onglet BD
Dim DernLigne As Integer
DernLigne = Worksheets("BD").Range("B" & Rows.Count).End(xlUp).Row

'Définition de la dernière ligne de l'onglet Liste_recherche
Dim DernLigneRech As Integer
DernLigneRech = Worksheets("Liste_recherche").Range("A" & Rows.Count).End(xlUp).Row

'Valeur à chercher
Dim LigneRech As Integer
For LigneRech = 2 To DernLigneRech
ValCherch = f3.Range("A" & LigneRech)
ValRemplace = f3.Range("B" & LigneRech)

'Remplacer le code fictif par le PF ou SE père
Dim LigneBD As Integer
For LigneBD = 1 To DernLigne
f1.Range("C" & LigneBD) = Replace(Range("C" & LigneBD), ValCherch, ValRemplace)
Next LigneBD
'Boucle de copie : si la valeur de la cellule (i,3) est égale à ValRemplace alors copier la ligne i dans l'onglet Nouvelle_gamme
Dim i As Integer
For i = 1 To DernLigne
If f1.Cells(i, 3).Value = ValRemplace Then

If IsEmpty(Plage) Then

Set Plage = f1.Range(Cells(i, 2), Cells(i, 18))
Else
Set Plage = Union(Plage, f1.Range(Cells(i, 2), Cells(i, 18)))
End If
End If
Next i

If IsEmpty(Plage) Then Exit Sub
Next LigneRech
'/////////DEPLACEMENT/////////////////////////////////////////
Set Desti = f2.Range("B65000").End(xlUp).Offset(1)
Plage.Copy Destination:=Desti
'//////////////////////////////////////////////////
'Rafraichissement ecran
Application.ScreenUpdating = True

End Sub

 

[lolobala]

Je ne m'attendais pas à autant de solutions
Merci à tous !

La solution "plus simple" de vgendron fonctionne très bien
Elle est tellement simplifié qu'elle dépasse mes connaissances d'ailleurs.

Je vais analysé ça de plus près
Encore merci à tous et bonne fin de journée

Laurent

 

[vgendron]

@lolobala

Celle de @fanch55 est pas mal non plus
si tu utilises l'enregistreur de macro (ce que j'avais commencé à faire comme le laisse penser le module 2 de ma proposition)
et que tu appliques des filtres sur ta base de données, tu retrouves l'idée du code de Fanch.