Discussion :

[lourid]

Bonsoir
dans le fichier que je joins, je dois vérifier que les valeurs dans la plage A: D sont égales aux valeurs de la plage I: L la plage E: H doit avoir VRAI, si une cellule contient Faux je dois couper la plage A: D la copier dans la feuille PIPPO range A1
déplace la plage sous les cellules supprimées et rend la plage E: H vraie.
Il est possible d'automatiser l'intégralité de la feuille pouvant contenir plus de 30 000 lignes.

[ARTURO83]

Bonjour,

Le fichier
Pièce jointe 485585

Le code

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
Option Compare Text
Option Explicit
 
Sub Compare()
    Dim f1 As Worksheet, f2 As Worksheet
    Dim Derlig_f1 As Long, Derlig_f2 As Long, i As Long, New_Lig As Long
 
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Set f1 = Sheets("intesta")
    Set f2 = Sheets("pippo")
 
    Derlig_f1 = f1.[A100000].End(xlUp).Row
    Derlig_f2 = f2.[A100000].End(xlUp).Row
    f1.Range(Cells(16, "E"), Cells(Derlig_f1, "H")).FormulaR1C1 = "=IF(RC1<>"""",RC[-4]=RC[4],"""")"
    f2.Cells.ClearContents
 
    New_Lig = 1
    For i = Derlig_f1 To 16 Step -1
        If f1.Cells(i, "A") <> f1.Cells(i, "I") Or f1.Cells(i, "B") <> f1.Cells(i, "J") Or f1.Cells(i, "C") <> f1.Cells(i, "K") Or f1.Cells(i, "D") <> f1.Cells(i, "L") Then
            f1.Range(Cells(i, "A"), Cells(i, "D")).Copy Destination:=f2.Cells(New_Lig, "A")
            New_Lig = New_Lig + 1
            f1.Range(Cells(i, "A"), Cells(i, "D")).Delete
        End If
    Next i
 
    'Réécriture des formules
    f1.Range(Cells(16, "E"), Cells(Derlig_f1 + 10, "H")).FormulaR1C1 = "=IF(RC1<>"""",RC[-4]=RC[4],"""")"
 
    Set f1 = Nothing
    Set f2 = Nothing
End Sub

Cdlt

[lourid]

Merci comme toujours Arturo pour son intérêt.
J'ai essayé la macro mais j'ai constaté qu'elle me supprime également les valeurs présentes à la fois dans la plage A: D et dans la plage I: L example
10002347 F1105 32 0
10002347 B0016 0 211,36

J'essaie d'expliquer manuellement ce que je fais:
je fais défiler les cellules pour ne pas trouver FALSE dans une cellule de la plage E: H à ce stade, ctrl x et je supprime les cellules correspondantes (plage A: D)
puis je les copie dans la feuille Pippo.
Maintenant, la plage A87: D87 est vide, puis je sélectionne la plage qui va de A88: D184 ctr x et je la copie dans la plage vide, puis je me déplace vers la plage E: H, sélectionne la plage où il y a VRAI. Double-cliquer et copier les formules dans afin qu'ils me reviennent VRAI. Je dois parcourir toute la table, qui peut contenir plus de 30 000 lignes, de manière à éviter les erreurs (en pratique, les valeurs présentes dans A B C D doivent être égales à I J K L

[ARTURO83]

Ok, parce que je suis parti du bas en remontant, correction:

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
Option Compare Text
Option Explicit
 
Sub Compare()
    Dim f1 As Worksheet, f2 As Worksheet
    Dim Derlig_f1 As Long, Derlig_f2 As Long, i As Long, New_Lig As Long
 
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Set f1 = Sheets("intesta")
    Set f2 = Sheets("pippo")
 
    Derlig_f1 = f1.[A100000].End(xlUp).Row
    Derlig_f2 = f2.[A100000].End(xlUp).Row
    f1.Range(Cells(16, "E"), Cells(Derlig_f1, "H")).FormulaR1C1 = "=IF(RC1<>"""",RC[-4]=RC[4],"""")"
    f2.Cells.ClearContents
 
    New_Lig = 1
    For i = 16 To Derlig_f1
        If i = 180 Then Stop
        If f1.Cells(i, "A") <> f1.Cells(i, "I") Or f1.Cells(i, "B") <> f1.Cells(i, "J") Or f1.Cells(i, "C") <> f1.Cells(i, "K") Or f1.Cells(i, "D") <> f1.Cells(i, "L") Then
            f1.Range(Cells(i, "A"), Cells(i, "D")).Copy Destination:=f2.Cells(New_Lig, "A")
            New_Lig = New_Lig + 1
            f1.Range(Cells(i, "A"), Cells(i, "D")).Delete
            'Réécriture des formules
            f1.Range(Cells(16, "E"), Cells(Derlig_f1 + 10, "H")).FormulaR1C1 = "=IF(RC1<>"""",RC[-4]=RC[4],"""")"
        End If
    Next i
 
    Set f1 = Nothing
    Set f2 = Nothing
End Sub

Mais pour les dernières lignes de votre tableau de droite, je ne comprends pas: comment avez-vous fait pour trouver la ligne en vert, puisqu'elle ne correspond pas à celle du tableau de gauche?
Pièce jointe 485632

[lourid]

Bonsoir Arturo j'ai essayé la macro avec une liste un peu différente mais 'je reste coincée je joins des fichiers

[ARTURO83]

Bonjour,

J'avais oublié d'enlever un test sur une ligne, Revoici le fichier avec une petite modification.

Pièce jointe 485711

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
Option Compare Text
Option Explicit
 
Sub Compare()
    Dim f1 As Worksheet, f2 As Worksheet
    Dim Derlig_f1 As Long, Derlig_f2 As Long, i As Long, New_Lig As Long
 
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Set f1 = Sheets("intesta")
    Set f2 = Sheets("pippo")
 
    Derlig_f1 = f1.[A100000].End(xlUp).Row
    Derlig_f2 = f2.[A100000].End(xlUp).Row
    f1.Range(Cells(16, "E"), Cells(Derlig_f1, "H")).FormulaR1C1 = "=IF(RC1<>"""",RC[-4]=RC[4],"""")"
    f2.Cells.ClearContents
 
    New_Lig = 1
    For i = 16 To Derlig_f1
        If f1.Cells(i, "A") = "" Or f1.Cells(i, "B") = "" Or f1.Cells(i, "C") = "" Or f1.Cells(i, "D") = "" Then Exit Sub
        If f1.Cells(i, "A") <> f1.Cells(i, "I") Or f1.Cells(i, "B") <> f1.Cells(i, "J") Or f1.Cells(i, "C") <> f1.Cells(i, "K") Or f1.Cells(i, "D") <> f1.Cells(i, "L") Then
            f1.Range(Cells(i, "A"), Cells(i, "D")).Copy Destination:=f2.Cells(New_Lig, "A")
            New_Lig = New_Lig + 1
            f1.Range(Cells(i, "A"), Cells(i, "D")).Delete Shift:=xlUp
            'Réécriture des formules
            f1.Range(Cells(16, "E"), Cells(Derlig_f1, "H")).FormulaR1C1 = "=IF(RC1<>"""",RC[-4]=RC[4],"""")"
            i = i - 1
        End If
    Next i
 
    Set f1 = Nothing
    Set f2 = Nothing
End Sub

Cdlt