comparaision entre les lignes

raniou010 · 19 Juillet 2018

Bonjour , avant de demander de l'aide, j'ai épluché tous les messages détaillant les comparaisons des feuilles excel. malheureusement, je n'ai pas trouvé ma solution .Svp quelqu’un peux m’aider ? J’ai un tableau excel de AM colonnes , je veux bien comparer les lignes avec la condition sile trio colonnes A , E et AM se répètent ensemble , alors la ligne entière sera copié dans une autre feuille ou bien coloré dans la même page

Exemple
(A) 12/01/2016 (B) ….. (c) ……(D) ……(E) azerty (F……AL) (AM) A

(A)13/01/2016 (B) ….. (c) ……(D) ……(E) azerty (F……AL) (AM) D

(A) 12/01/2016 (B) ….. (c) ……(D) ……(E) azerty (F……AL) (AM) A

A) 12/01/2016 (B) ….. (c) ……(D) ……(E) wxcvb (F……AL) (AM) A

Alors les lignes qui m’intéresse sont la première et la 3eme
merci

raniou010 · 19 Juillet 2018

yeti_yeti à dit:
Option Explicit

Sub CopyDuplicates()
Dim mycolor As Long, ws1 As Worksheet, ws2 As Worksheet 'Constantes
Dim i As Integer, p As Integer, e As Integer, s As Integer, c As Integer 'Variables

'Déclaration constantes
mycolor = 65535 'Code couleur à chercher (ici jaune)
With ThisWorkbook
Set ws1 = .Sheets("Sheet1") 'Nom feuille 100'000 lignes
Set ws2 = .Sheets("Sheet2") ' Nom feuille où copier
End With

'Déclaration variables
c = ws1.UsedRange.Column
s = ws1.UsedRange.Row
e = ws1.Cells(ws1.Rows.Count, c).End(xlUp).Row 'Dernière ligne du tableau
p = ws2.Cells(ws2.Rows.Count, c).End(xlUp).Row + 1 'Première ligne vide du tableau

'###############
'# DEBUT MACRO #
'###############
For i = s To e
If ws1.Cells(i, 1).Interior.Color = mycolor Then
ws1.Cells(i, 1).EntireRow.Copy Destination:=ws2.Rows(p)
p = p + 1
End If
Next i

End Sub

toujour un probleme avec la ligne Set ws1 = .Sheets("Sheet1") 'Nom feuille 100'000 lignes malgré que je mets le nom de la feuille !

yeti_yeti · 19 Juillet 2018

Alors plutôt que de travailler avec le nom (qui est entre parenthèses dans votre projet VBA), travaillez avec le code de la feuille (celui se trouve avant les parenthèses)

Code:

Option Explicit

Sub CopyDuplicates()
Dim mycolor As Long, ws1 As Worksheet, ws2 As Worksheet 'Constantes
Dim i As Integer, p As Integer, e As Integer, s As Integer, c As Integer 'Variables

'Déclaration constantes
mycolor = 65535 'Code couleur à chercher (ici jaune)
Set ws1 = Sheet5 'Nom feuille 100'000 lignes
Set ws2 = Sheet6 ' Nom feuille où copier

'Déclaration variables
With ws1
    With .UsedRange
        c = .Column 'Première colonne du tableau
        s = .Row 'Première ligne du tableau
    End With
    e = .Cells(.Rows.Count, c).End(xlUp).Row 'Dernière ligne du tableau
End With
p = ws2.Cells(ws2.Rows.Count, c).End(xlUp).Row + 1 'Première ligne vide du tableau

'###############
'# DEBUT MACRO #
'###############
    For i = s To e
        With ws1.Cells(i, 1)
            If .Interior.Color = mycolor Then
                .EntireRow.Copy Destination:=ws2.Rows(p)
                p = p + 1
            End If
        End With
    Next i
   
End Sub

raniou010 · 19 Juillet 2018

yeti_yeti à dit:

Alors plutôt que de travailler avec le nom (qui est entre parenthèses dans votre projet VBA), travaillez avec le code de la feuille (celui se trouve avant les parenthèses)

Regarde la pièce jointe 1015496

Code:

Option Explicit

Sub CopyDuplicates()
Dim mycolor As Long, ws1 As Worksheet, ws2 As Worksheet 'Constantes
Dim i As Integer, p As Integer, e As Integer, s As Integer, c As Integer 'Variables

'Déclaration constantes
mycolor = 65535 'Code couleur à chercher (ici jaune)
Set ws1 = Sheet5 'Nom feuille 100'000 lignes
Set ws2 = Sheet6 ' Nom feuille où copier

'Déclaration variables
c = ws1.UsedRange.Column
s = ws1.UsedRange.Row
e = ws1.Cells(ws1.Rows.Count, c).End(xlUp).Row 'Dernière ligne du tableau
p = ws2.Cells(ws2.Rows.Count, c).End(xlUp).Row + 1 'Première ligne vide du tableau

'###############
'# DEBUT MACRO #
'###############
    For i = s To e
        With ws1.Cells(i, 1)
            If .Interior.Color = mycolor Then
                .EntireRow.Copy Destination:=ws2.Rows(p)
                p = p + 1
            End If
        End With
    Next i
  
End Sub

dépassement de capacoté , aufaite , il faut que la macro fait tous la recherche et quant elle trouve les duplication elle les copies dans une autre feuille ca car la mise en forme a bloque mon pc carement :/

yeti_yeti · 19 Juillet 2018

Comme je vous le dis depuis le début... il y a trop de lignes et le PC va bloquer systématiquement... S'il existe une façon, je ne la connais pas, désolé

Néanmoins, voici la macro que vous voulez, sans garanties que cela résolve le problème... A adapter la déclaration constantes à votre fichier

Code:

Option Explicit

Sub CopyDuplicates()
Dim ws1 As Worksheet, ws2 As Worksheet, c1 As Integer, c2 As Integer, c3 As Integer 'Constantes
Dim i As Integer, ni As Integer, p As Integer, e As Integer, s As Integer, c As Integer, SearchID As String, MatchID As String 'Variables

'Déclaration constantes
Set ws1 = Sheet5 'Nom feuille 100'000 lignes
Set ws2 = Sheet6 ' Nom feuille où copier
c1 = 1 'Colonne A
c2 = 5 'Colonne E
c3 = 39 'Colonne AM

'Déclaration variables
With ws1
    With .UsedRange
        c = .Column 'Première colonne du tableau
        s = .Row 'Première ligne du tableau
    End With
    e = .Cells(.Rows.Count, c).End(xlUp).Row 'Dernière ligne du tableau
End With
p = ws2.Cells(ws2.Rows.Count, c).End(xlUp).Row + 1 'Première ligne vide du tableau

'###############
'# DEBUT MACRO #
'###############

'Geler Excel
With Application
    .ScreenUpdating = False
    .Calculation = xlCalculationManual
    .EnableEvents = False
End With

With ws1
    For i = s To e
    SearchID = .Cells(i, c1).Value & .Cells(i, c2).Value & .Cells(i, c3).Value
        For ni = s To e
            If i <> ni Then
                MatchID = .Cells(ni, c1).Value & .Cells(ni, c2).Value & .Cells(ni, c3).Value
                If SearchID = MatchID Then
                        .Cells(ni, 1).EntireRow.Copy Destination:=ws2.Rows(p)
                        p = p + 1
                End If
            End If
        Next ni
    Next i
End With

'Dégeler Excel
With Application
    .ScreenUpdating = True
    .Calculation = xlCalculationAutomatic
    .EnableEvents = True
End With

End Sub

Dranreb · 19 Juillet 2018

Bonsoir.
Je pense que ça peut se faire par macro en employant les ressources Excel :
1) — Classer le tableau sur les arguments qui ne doivent pas être en double
2) — Installer une formule temporaire genre =1/(condition), la condition étant que les 3 arguments sont identiques dans la ligne et celle qui la précède
3) — Supprimer, couper/coller ou colorier les lignes entières des cellules de la colonne formule portant une valeur spéciale numérique.
4) — Supprimer la colonne formule.

mapomme · 20 Juillet 2018

Bonjour à tous,

Ma modeste contribution (coloriage des lignes en double ou plus). Ça ressemble beaucoup à ce qu'a proposé @Dranreb que je salue .
Une fois les doublons repérés, il suffit de filtrer les colonnes A à AM et de trier la colonne AM sur la couleur pour rassembler les doublons en un seul bloc.

VB:

Sub Doublons()
Dim derlig&, i&, rgcol As Range, xrg As Range

    Application.ScreenUpdating = False
    Range("an:ao").Clear
    derlig = Cells(Rows.Count, "a").End(xlUp).Row
    i = Cells(Rows.Count, "e").End(xlUp).Row
    If i > derlig Then derlig = i
    i = Cells(Rows.Count, "am").End(xlUp).Row
    If i > derlig Then derlig = i
    Set rgcol = Range("am2:am" & derlig)
    rgcol.Offset(, 1).FormulaR1C1 = "=ROW()"
    rgcol.Offset(, 1).Value = rgcol.Offset(, 1).Value
    With Range("a1:an" & derlig)
        .Sort key1:=Range("a1"), order1:=xlAscending, _
              key2:=Range("e1"), order2:=xlAscending, _
              key3:=Range("am1"), order3:=xlAscending, _
              Header:=xlYes
    End With
    rgcol.Offset(, 2).FormulaR1C1 = "=(RC[-40]=R[-1]C[-40])*(RC[-36]=R[-1]C[-36])*(RC[-2]=R[-1]C[-2])+(RC[-40]=R[1]C[-40])*(RC[-36]=R[1]C[-36])*(RC[-2]=R[1]C[-2])"
    rgcol.Offset(, 2).Value = rgcol.Offset(, 2).Value
    With Range("a1:ao" & derlig)
        .Sort key1:=Range("ao1"), order1:=xlAscending, _
              Header:=xlYes
    End With
    On Error Resume Next
    i = 0
    Set xrg = Range("ao:ao").Find(what:=1, lookat:=xlWhole, LookIn:=xlValues)
    On Error GoTo 0
    Range("a:am").Interior.ColorIndex = xlColorIndexNone
    If Not xrg Is Nothing Then
      i = xrg.Row
      Range(Cells(xrg.Row, "a"), Cells(derlig, "am")).Interior.Color = RGB(255, 255, 0)
    End If
    With Range("a1:an" & derlig)
        .Sort key1:=Range("an1"), order1:=xlAscending, _
              Header:=xlYes
    End With
    Range("an:ao").Clear
    Range("a1:am1").Interior.Color = RGB(200, 200, 200)
    If i > 0 Then i = derlig - i + 1
    MsgBox i & " doublon(s)"
End Sub

Edit : si dans le code, on met en commentaire le dernier tri, alors les doublons sont tous regroupés en fin de colonne. Code à mettre en commentaire:

VB:

    With Range("a1:an" & derlig)
        .Sort key1:=Range("an1"), order1:=xlAscending, _
              Header:=xlYes
    End With

raniou010 · 23 Juillet 2018

yeti_yeti à dit:

Comme je vous le dis depuis le début... il y a trop de lignes et le PC va bloquer systématiquement... S'il existe une façon, je ne la connais pas, désolé

Néanmoins, voici la macro que vous voulez, sans garanties que cela résolve le problème... A adapter la déclaration constantes à votre fichier

Code:

Option Explicit

Sub CopyDuplicates()
Dim ws1 As Worksheet, ws2 As Worksheet, c1 As Integer, c2 As Integer, c3 As Integer 'Constantes
Dim i As Integer, ni As Integer, p As Integer, e As Integer, s As Integer, c As Integer, SearchID As String, MatchID As String 'Variables

'Déclaration constantes
Set ws1 = Sheet5 'Nom feuille 100'000 lignes
Set ws2 = Sheet6 ' Nom feuille où copier
c1 = 1 'Colonne A
c2 = 5 'Colonne E
c3 = 39 'Colonne AM

'Déclaration variables
With ws1
    With .UsedRange
        c = .Column 'Première colonne du tableau
        s = .Row 'Première ligne du tableau
    End With
    e = .Cells(.Rows.Count, c).End(xlUp).Row 'Dernière ligne du tableau
End With
p = ws2.Cells(ws2.Rows.Count, c).End(xlUp).Row + 1 'Première ligne vide du tableau

'###############
'# DEBUT MACRO #
'###############

'Geler Excel
With Application
    .ScreenUpdating = False
    .Calculation = xlCalculationManual
    .EnableEvents = False
End With

With ws1
    For i = s To e
    SearchID = .Cells(i, c1).Value & .Cells(i, c2).Value & .Cells(i, c3).Value
        For ni = s To e
            If i <> ni Then
                MatchID = .Cells(ni, c1).Value & .Cells(ni, c2).Value & .Cells(ni, c3).Value
                If SearchID = MatchID Then
                        .Cells(ni, 1).EntireRow.Copy Destination:=ws2.Rows(p)
                        p = p + 1
                End If
            End If
        Next ni
    Next i
End With

'Dégeler Excel
With Application
    .ScreenUpdating = True
    .Calculation = xlCalculationAutomatic
    .EnableEvents = True
End With

End Sub

bonjour , merci ca marche mais il y'a un problème dans la boucle , la macro copie 4 ou 5 fois les ligne en duplication dans la 2em feuille ! j'ai pas compris ou il est le problème exactement

comparaision entre les lignes

raniou010

XLDnaute Nouveau

raniou010

XLDnaute Nouveau

yeti_yeti

XLDnaute Junior

raniou010

XLDnaute Nouveau

yeti_yeti

XLDnaute Junior

Dranreb

XLDnaute Barbatruc

mapomme

XLDnaute Barbatruc

Pièces jointes

raniou010

XLDnaute Nouveau

Discussions similaires