comparaision entre les lignes

raniou010

raniou010

XLDnaute Nouveau
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
 
Trier par date Trier par votes
raniou010

raniou010

XLDnaute Nouveau
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
Cliquez pour agrandir...
toujour un probleme avec la ligne Set ws1 = .Sheets("Sheet1") 'Nom feuille 100'000 lignes malgré que je mets le nom de la feuille !
 
Vote positif 0 Vote négatif
Y

yeti_yeti

XLDnaute Junior
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)

upload_2018-7-19_16-26-7.png


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
 
Dernière édition:
Vote positif 0 Vote négatif
raniou010

raniou010

XLDnaute Nouveau
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
Cliquez pour agrandir...
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 :/
 
Vote positif 0 Vote négatif
Y

yeti_yeti

XLDnaute Junior
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
 
Vote positif 0 Vote négatif
Dranreb

Dranreb

XLDnaute Barbatruc
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.
 
Vote positif 0 Vote négatif
mapomme

mapomme

XLDnaute Barbatruc
Supporter XLD
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
 

Pièces jointes

  • raniou010- reperer doublons- v1.xlsm
    21.5 KB · Affichages: 41
Dernière édition:
Vote positif 0 Vote négatif
raniou010

raniou010

XLDnaute Nouveau
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
Cliquez pour agrandir...
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
 
Vote positif 0 Vote négatif

Discussions similaires

G
  • Question
XL 2016 Compte à rebours dans un userform
2
Réponses
15
Affichages
610
patricktoulon
patricktoulon
A
  • Question
Microsoft 365 Planning automatique
Réponses
0
Affichages
480
Aboly
A
D
  • Question
XL 2016 Exporter au format PDF dans un dossier existant les colonnes ciblées et en filtrant les lignes qui contiennent une valeur quelconque.
Réponses
6
Affichages
652
Phil69970
Phil69970
Roland_M
  • Question
XL 2016 Tri (Filtrer) ne tri pas toutes les colonnes !?
Réponses
6
Affichages
784
Roland_M
Roland_M
A
  • Résolu(e)
Microsoft 365 Correction d'un code vba
2
Réponses
22
Affichages
1 K
AD95
A
F
  • Question
XL 2019 Extraire des lignes suivant somme des colonnes pour alimenter un autre tableau
Réponses
1
Affichages
404
fanfan38
fanfan38
B
  • Question
XL 2013 Automatiser une formule sur les nouvelles lignes insérées en fonction d'une recherche sur les enregistrements
Réponses
9
Affichages
476
bedley
B
T
  • Résolu(e)
XL 2019 VBA - Comparaison d'heures
Réponses
9
Affichages
392
ThierryP
T
I
  • Résolu(e)
Microsoft 365 Fusion de lignes avec condition pour certaines colonnes
Réponses
14
Affichages
903
Hasco
Hasco
A
  • Question
XL 2016 Sous-totaux ou WorksheetFunction.Sum
Réponses
2
Affichages
700
Aldonanou
A

Membres actuellement en ligne

15 membres et 67 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
315 096
Messages
2 116 179
Membres
112 677
dernier inscrit
Justine11