macro de comparaison de valeurs et insertion ligne à chaque valeurs trouvées

[gwad063]

Bonjour,

Suite à mon post "Macro de recherche de valeurs dans un fichier en arborescence " d'avant hier sur lequel JP14 et BQTR m'avaient bien aidé, je reviens vers vous (la communauté dans son ensemble) parce que j'ai un nouveau problème dans mon projet : voilà, j'ai donc ma macro de recherche dans un fichier en arborescence qui fonctionne et maintenant, voilà ce qu'il faut que je fasse :

J'ai un fichier nommé "Proposition BPR 1", dedans 3 onglets :
- Transactions par rôle ;
- Transactions BPR;
- Spécifique.

Seuls le 2ème et le 3ème me sont utiles :
il faut que je créé une macro de recherche qui compare la colonne A de ma feuille "spécifique" à ma colonne E de ma feuille Transaction BPR; dès qu'elle a trouvé la même valeur, insère dans la feuille "Transaction BPR", juste en dessous de la ligne où elle a trouvé cette valeur:
- en colonne A, la valeur se trouvant en colonne B de la feuille "spécifique";
- en colonne B, C, D et E les valeurs des colonnes B, C, D et E de la ligne juste au dessus;

Et également que cette ligne insérée à chaque fois qu'une même valeur est trouvée soit automatiquement colorée afin de pouvoir mieux se repérer...

J'ai commencé à faire quelquechose, il y a pas mal d'erreurs, je pense que ça va en faire rire plusieurs d'entre vous mais bon comme je le disais dans mon post précédent, je débute (et j'aimerai bien comprendre mes erreurs...) :

Sub RecherchSpec()
Dim i As Long
Dim j As Long
Dim Wb As Workbook
Dim Ws As Sheets
Dim Role As Range
Dim TransSpec As Range
Sheets("Specifiques").Activate
Set Wb = Workbooks("Proposition BPR 1.xls")
Set Ws = Wb.Sheets("Specifique")


For i = 1 To 260

Set Role = Ws.Range("A, i")
Set TransSpec = Ws.Range("B, i")
Sheets("Transactions BPR").Activate
For j = 1 To 3000
If Wb.Sheets("transactions BPR").Range(E, j).FormulaR1C1 = Role.FormulaR1C1 Then
Rows(j + 1).Select
Selection.Insert Shift:=xlDown
Selection.Interior.ColorIndex = 44
Wb.Sheets("Transactions BPR").Range(A, j + 1).FormulaR1C1 = Ws.Range(B, i).FormulaR1C1
Wb.Sheets("Transactions BPR").Range(E, j + 1).FormulaR1C1 = Ws.Range(A, i).FormulaR1C1
Wb.Sheets("Transactions BPR").Range(B, j + 1).FormulaR1C1 = Ws.Range(B, j).FormulaR1C1
Wb.Sheets("Transactions BPR").Range(C, j + 1).FormulaR1C1 = Ws.Range(C, j).FormulaR1C1
Wb.Sheets("Transactions BPR").Range(D, j + 1).FormulaR1C1 = Ws.Range(D, j).FormulaR1C1
End If
Next j
Next i
End Sub

Voilà, j'espère que sur le descriptif, ça vous paraît assez clair, sinon, n'hésitez pas, au pire, je mettrai mon fichier en pièce jointe...
Merci d'avance.

 

[jp14]

Re : macro de comparaison de valeurs et insertion ligne à chaque valeurs trouvées

Bonjour

On gagne du temps lorsque on a le fichier cela évite de retaper les données, le nom des feuilles, ... et cela facilite la mise au point.

JP

 

[gwad063]

Re : macro de comparaison de valeurs et insertion ligne à chaque valeurs trouvées

Bonjour JP,
effectivement, ci-joint le fichier...

 

[jp14]

Re : macro de comparaison de valeurs et insertion ligne à chaque valeurs trouvées

Bonjour

Ci joint un fichier avec une macro a tester.

JP

 

[gwad063]

Re : macro de comparaison de valeurs et insertion ligne à chaque valeurs trouvées

Je vais tester ça...
Merci JP, décidément, c'est la 2ème fois que tu me sors de la "muiz"...
Bonne soirée.

Alex

 

[skoobi]

Re : macro de comparaison de valeurs et insertion ligne à chaque valeurs trouvées

Re bonsoir,

je te propose une autre macro sans la fonction "recherchemot":

Option Explicit


Sub recherche3()
Dim i As Long
Dim lidep1 As Long
Dim nomfeuille1 As String
Dim nomfeuille2 As String
Dim firstlig As Long
Dim col1 As String
Dim lig As Long
Dim cel As Range
Application.ScreenUpdating = False 'gele l'ecran

lidep1 = 2
nomfeuille2 = "Transactions BPR"
nomfeuille1 = "Specifiques"
col1 = "a"
For i = lidep1 To Sheets(nomfeuille1).Range(col1 & "65536").End(xlUp).Row
'    lig = recherchemot("e3:e" & Sheets(nomfeuille2).Range("e65536").End(xlUp).Row, Sheets(nomfeuille1).Range(col1 & i), nomfeuille2, 1)
'    With Sheets(nomfeuille2).Range("e3:e" & Sheets(nomfeuille2).Range("e65536").End(xlUp).Row)
    With Sheets(nomfeuille2).Columns("e:e")
         Set cel = .Find(Sheets(nomfeuille1).Range(col1 & i), LookIn:=xlValues, SearchOrder:=xlByRows, searchdirection:=xlPrevious, lookat:=xlWhole) ' on recherche ligne par ligne
        If Not cel Is Nothing Then
           firstlig = cel.Row
           lig = cel.Row
            Do
                Sheets(nomfeuille2).Rows(lig + 1).Insert Shift:=xlDown
        ' en colonne A, la valeur se trouvant en colonne B de la feuille "spécifique";
        '- en colonne B, C, D et E les valeurs des colonnes B, C, D et E de la ligne juste au dessus;
                Sheets(nomfeuille2).Range("B" & lig & ":E" & lig).Copy Sheets(nomfeuille2).Range("B" & lig + 1)
                Sheets(nomfeuille2).Range("a" & lig + 1) = Sheets(nomfeuille1).Range("B" & i)
                Sheets(nomfeuille2).Range(Range("A" & lig + 1), Range("E" & lig + 1)).Interior.ColorIndex = 44
                Set cel = .FindPrevious(cel)
                lig = cel.Row
                firstlig = firstlig + 1
Debug.Print i
            Loop While Not cel Is Nothing And cel.Row <> firstlig
        End If
    End With
Debug.Print i
Next i

Application.ScreenUpdating = True 'réaffiche l'ecran

End Sub

 

[gwad063]

Re : macro de comparaison de valeurs et insertion ligne à chaque valeurs trouvées

Bonjour à tous,

Merci beaucoup Skoobi; j'ai tester ta macro : ça marche!
Par contre, je n'ai pas été jusqu'au bout parce je l'ai laissé tourner 3 heures et ce n'était pas terminé (sachant que le 1er fichier "Transactions BPR" fait environ 3500 lgns et l'autre environ 300... );
DU coup, avec de l'aide en interne, j'ai récupéré une solution modifiant très peu mon code initial (en bleu, les modif me permettant de faire ma boucle), pensant que la fonction "recherchemot" me ferait gagner du temps ; ce n'est pas le cas, je pense qu'elles fonctionnent de façon assez similaires et du coup, je me suis rendu compte que la boucle provoque un autre problème auquel je n'avais pas vraiment pensé et que je ne vois pas trop comment contourné...

La macro :

Option Explicit
'pour chaque rôle de l'onglet "Specifique" trouvée dans "Transactions_BPR"
'Insertion d'une ligne dans "Transactions_BPR" juste après la ligne de la valeur trouvée,
'dans laquel va venir s'incrémentée la transaction spécifique (colonne A), et recopie de l'étape, process, scénario et rôle auquel elle serait susceptible ede correspondre.
'cette ligne va se colorer pour plus de visibilité.
Sub RechercheSpec()
Dim i As Long
Dim cell As Range
Dim lidep1 As Long
Dim NomFeuille1 As String
Dim NomFeuille2 As String
Dim col1 As String
Dim lig As Long
Application.ScreenUpdating = True 'gele l'ecran
lidep1 = 2
col1 = "a"
NomFeuille1 = "Specifiques"
NomFeuille2 = "Transactions BPR"
For i = lidep1 To Sheets(NomFeuille1).Range(col1 & "65536").End(xlUp).Row
'**** Modif 1***'
'* Init la ligne et boucle tant qu'on est pas à la fin du fichier et la valeur cheché et trouvé*'
lig = lidep1
Do
'**** fin modif ****
'Appel de la macro "recherchemot" qui est une macro de recherche de valeur... lig = recherchemot("e" & lig + 1 & ":e" & Sheets(NomFeuille2).Range("e65536").End(xlUp).Row, Sheets(NomFeuille1).Range(col1 & i), NomFeuille2, 1)
'si elle trouve la valeur, alors-> insertion de ligne, copie de valeurs en colonne B, C, D et E de la ligne du dessus
'+ aller chercher la valeur dans la colonne A de "Specifique". If lig <> 0 Then
Sheets(NomFeuille2).Select
Rows(lig + 1).Select
Selection.Insert Shift:=xlDown
'Selection.Interior.ColorIndex = 44
' en colonne A, la valeur se trouvant en colonne B de la feuille "spécifique";
'- en colonne B, C, D et E les valeurs des colonnes B, C, D et E de la ligne juste au dessus; Range("B" & lig & "" & lig).Select
Application.CutCopyMode = False
Selection.Copy
Range("B" & lig + 1).Select
ActiveSheet.Paste
Sheets(NomFeuille2).Range(Range("A" & lig + 1), Range("E" & lig + 1)).Interior.ColorIndex = 44
'Selection.Interior.ColorIndex = 44 '**** Modif 2***'
'**** Sortir de la boucle si fin de liste atteinte If Range("E" & lig + 2).Value = "" Then Exit Do
'**** fin Modif ***' Sheets(NomFeuille1).Select
Sheets(NomFeuille2).Range("a" & lig + 1) = Sheets(NomFeuille1).Range("B" & i)
'**** Modif 3***'
'*** Ne pas prendre en compte la ligne qui vient d'etre ajouté lig = lig + 1
'**** Fin Modif ***'
End If
'**** Modif 4***'
'**** Fin de boucle' Loop While lig <> 65536 And lig <> 0
'**** Modif ***'Next i
Application.ScreenUpdating = False 'gele l'ecran
End Sub
'---------------------------------------------------------------------------------------
' Procedure : recherchemot
'=recherchemot(plage_pour la recherche,valeur_cherché,nom_de_la_feuille, code_retour )
' ad plage de recherche
'ad = "a2:" & Sheets("rue").Cells.SpecialCells(xlCellTypeLastCell).Address(0, 0) ' on recherche dans l'ensemble de la feuille
'
'---------------------------------------------------------------------------------------
'
Private Function recherchemot(plage_recherche As String, valcherche As String, nom_de_la_feuille As String, code_retour As Byte)
Dim firstAddress As String
Dim firstRow As String
Dim cel As Range
Dim ligne1 As Long
Dim ligne2 As Long
With Sheets(nom_de_la_feuille).Range(plage_recherche)
Set cel = .Find(valcherche, LookIn:=xlValues, SearchOrder:=xlByRows, lookat:=xlWhole) ' on recherche ligne par ligne 'Set c = .Find(valcherche, LookIn:=xlFormulas, SearchOrder:=xlByRows) 'si date
'Set £c = .Find(dataf, LookIn:=xlValues, MatchCase:=True, _
SearchOrder:=xlByRows, lookat:=xlWhole)
If Not cel Is Nothing Then
If code_retour = 1 Then recherchemot = cel.Row
If code_retour = 2 Then recherchemot = cel.Address
'Do
'Set cel = .FindNext(cel)
'Loop While recherchemot = 0
Exit Function
End If
End With
recherchemot = 0
End Function

Le problème :
En fait, dans les 2 cas, ces macros ont les défauts de leur qualité; je m'explique :
- à chaque fois qu'elle trouve la valeur dans la colonne E de "Transaction BPR", elle insère une ligne et l'incrémente des valeurs qui vont bien (en recopiant les valeurs du dessus des colonnes B jusqu'à E)et cela jusqu'à ce qu'elle ne trouve plus la valeur, ensuite, elle passe à la suivante: or, vu que ma valeur recherchée est dans ma colonne E, lorsqu'elle passe à ma valeur suivante, il va venir insérer une ligne à chaque fois qu'elle retrouve la valeur dans E; y compris après les lignes qui viennent d'être insérer précédemment (je sais pas si c'est très clair): donc je me retrouve avec des doublons, voire parfois 3, 4, je pense même jusqu'à 10 ou x fois la même ligne insérer et de plus, c'est exponentiel (c'est pour ça je pense que ça met tant de temps); plus elle retrouve la valeur dans la colonne E, plus elle insère de lignes et plus ya de chance qu'elle retrouve la valeur dans la colonne E, etc...donc ça devient une usine à gaz.

La solution que je pensais avoir trouvé; c'était à ce moment là de ne pas copier al valeur de la colonne E lorsqu'elle insère une ligne; mais ça ne marche pas car lorsqu'il y a déjà eu une ligne d'insérée, je n'aurai pas le nom de ma transaction en colonne A...
Donc là, une fois de plus, je relance ce post en espèrant encore un peu d'aide ou conseil sur mon problème...
Merci.

Gwad.

 

[skoobi]

Re : macro de comparaison de valeurs et insertion ligne à chaque valeurs trouvées

Re bonjour,

Si tu reprends le code que je t'ai donné et le fichier de jp14, la macro s'execute en environ 20 secondes.
Ca t'avance pas beaucoup là mais:

As-tu remarqué que lorsque tu as "Rôles" qu'une seul fois dans la feuille "Specifiques", la copie se passe correctement mais dès que tu qu'il s'y trouve plusieurs fois le même roles et bien il reprend la boucle......
test la macro en pas à pas et tu verras.
Bon courage.

 

[gwad063]

Re : macro de comparaison de valeurs et insertion ligne à chaque valeurs trouvées

Skoobi,
je l'ai exécuté pas à pas pour vérifier qu'elle marchait (et c'est effectivement le cas) et c'est vrai que dans le fichier de JP, ça doit être rapide. Par contre, quand je l'ai lancé dans mon fichier original, c'est là que j'ai été obligé de l'arrêter parce qu'au point où ça en était, je suis pas sûr que l'après-midi aurait suffit (remarque, c'est pareil pour celle que je viens de mettre dans le poste du dessus...).
En fait, je pense qu'il faudrait que je rajoute un élément "discriminant" pour que la recherche ne prenne pas en compte les lignes déjà insérées, genre les lignes colorées (vu que chaque ligne insérée est colorée).
En tout cas merci pour le temps déjà consacré à mon problème...

gwad.

 

[skoobi]

Re : macro de comparaison de valeurs et insertion ligne à chaque valeurs trouvées

Re,

En fait, je pense qu'il faudrait que je rajoute un élément "discriminant" pour que la recherche ne prenne pas en compte les lignes déjà insérées, genre les lignes colorées

J'ai modifié le code pour la détection de la couleur, en vert l'ajout et en bleu ce qui a été déplacé:

Option Explicit


Sub recherche3()
Dim i As Long
Dim lidep1 As Long
Dim nomfeuille1 As String
Dim nomfeuille2 As String
Dim firstlig As Long
Dim col1 As String
Dim lig As Long
Dim cel As Range
Application.ScreenUpdating = False 'gele l'ecran

lidep1 = 2
nomfeuille2 = "Transactions BPR"
nomfeuille1 = "Specifiques"
col1 = "a"
For i = lidep1 To Sheets(nomfeuille1).Range(col1 & "65536").End(xlUp).Row
'    lig = recherchemot("e3:e" & Sheets(nomfeuille2).Range("e65536").End(xlUp).Row, Sheets(nomfeuille1).Range(col1 & i), nomfeuille2, 1)
'    With Sheets(nomfeuille2).Range("e3:e" & Sheets(nomfeuille2).Range("e65536").End(xlUp).Row)
    With Sheets(nomfeuille2).Columns("e:e")
         Set cel = .Find(Sheets(nomfeuille1).Range(col1 & i), LookIn:=xlValues, SearchOrder:=xlByRows, searchdirection:=xlPrevious, lookat:=xlWhole) ' on recherche ligne par ligne
        If Not cel Is Nothing Then
           firstlig = cel.Row
           lig = cel.Row
            Do
[B][COLOR="Green"]                If Not cel.Offset(0, -4).Interior.ColorIndex = 44 Then[/COLOR][/B]
                    Sheets(nomfeuille2).Rows(lig + 1).Insert Shift:=xlDown
            ' en colonne A, la valeur se trouvant en colonne B de la feuille "spécifique";
            '- en colonne B, C, D et E les valeurs des colonnes B, C, D et E de la ligne juste au dessus;
                    Sheets(nomfeuille2).Range("B" & lig & ":E" & lig).Copy Sheets(nomfeuille2).Range("B" & lig + 1)
                    Sheets(nomfeuille2).Range("a" & lig + 1) = Sheets(nomfeuille1).Range("B" & i)
                    Sheets(nomfeuille2).Range(Range("A" & lig + 1), Range("E" & lig + 1)).Interior.ColorIndex = 44
[B][COLOR="Blue"]                    firstlig = firstlig + 1[/COLOR][/B]
[COLOR="Green"][B]                End If[/B][/COLOR]
                Set cel = .FindPrevious(cel)
                lig = cel.Row
                
Debug.Print i
            Loop While Not cel Is Nothing And cel.Row <> firstlig
        End If
    End With
Debug.Print i
Next i

Application.ScreenUpdating = True 'réaffiche l'ecran

End Sub

 

[gwad063]

Re : macro de comparaison de valeurs et insertion ligne à chaque valeurs trouvées

Bonjour,

Vraiment merci Skoobi!!!
J'essaie ça dans la foulée...

Gwad.

 

[gwad063]

Re : macro de comparaison de valeurs et insertion ligne à chaque valeurs trouvées

Skoobi,

ça marche nickel;t'es un killer.

Merci beaucoup.
Bonne fin d'aprem.

Gwad