Vérification des valeurs de cellule

Version imprimable

21/06/2019, 21h00
lourid

1 pièce(s) jointe(s)

Vérification des valeurs de cellule

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.

Bonjour,

Le fichier
Pièce jointe 485585

Le code

Code:

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

22/06/2019, 15h35
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

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

Code:

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

22/06/2019, 22h36
lourid

2 pièce(s) jointe(s)

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

Bonjour,

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

Pièce jointe 485711

Code:

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

25/06/2019, 20h51
lourid

1 pièce(s) jointe(s)

Arturo J'ai essayé la macro avec un fichier avec plusieurs lignes. ça plante je ne peux pas comprendre !!!
Je joins un fichier

Bonjour,

Le problème vient du fait que d'un côté les cellules sont au format texte et de l'autre au format numérique (colonne A et I, B et J).
Voici le correctif, attention pensez à la traduction en italien.

Code:

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 = "=EXACT(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, "E") = "FAUX" Or f1.Cells(i, "F") = "FAUX" Or f1.Cells(i, "G") = "FAUX" Or f1.Cells(i, "H") = "FAUX" 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 = "=EXACT(RC[-4],RC[4])"
            i = i - 1
        End If
    Next i
 
    Set f1 = Nothing
    Set f2 = Nothing
End Sub

le fichier
Pièce jointe 486528

Cdlt

26/06/2019, 08h51
lourid

merci beaucoup Arturo
J'essaie de traduire la macro en italien et je l'essaie sur un fichier de plus de 30 000 lignes!!!