test liste si doublon

[ngexcel]

BONJOUR

je voudrais modifier cette macro pour trier une liste en colonne A puis D et H
je voudrais supprimer les lignes doublons
Merci

Option Explicit

Sub oterdoublons()
Dim N&, plage As Range
Application.ScreenUpdating = False
N = Cells(Rows.Count, "a").End(xlUp).Row
Columns("a:a").Insert
Set plage = Range("a1:i" & N)
plage.Columns(1).FormulaR1C1 = "=IF(RC[1]<>R[1]C[1],"""",NA())"
plage.Sort key1:=Range("b1"), order1:=xlAscending, key2:=Range("i1"), order2:=xlAscending, Header:=xlYes
plage.Columns(1).Value = plage.Columns(1).Value
plage.Sort key1:=Range("a1"), order1:=xlAscending, Header:=xlYes
N = Cells(Rows.Count, "a").End(xlUp).Row
If N >= 2 Then Range(Cells(2, "a"), Cells(N, "i")).Delete xlShiftUp
Columns("a:a").Delete
Application.ScreenUpdating = True
Dim i&, Rep$
Rep = ThisWorkbook.Path
For i = [A65536].End(3).Row To 1 Step -1
If Dir(Rep & "\" & Cells(i, 1) & "*") = "" Then
Rows(i).EntireRow.Delete
End If
Next
End Sub

 

[sousou]

Re : test liste si doublon

Bonjour ngexel
Essai ce code, il opère les trois opération les unes derrière les autres
initialise chemin qui sera le chemin du répertoire ou sont rangé test fichiers sans oublier le '\'
Cette partie n'est pas testée.

Public tableau
public const chemin = "chemin du répertoire concerné"
Sub action()
'tri
With Sheets("base")
Set tableau = .Range(.Cells(2, 1), .Cells(.Range("a2").End(xlDown).Row, 8))
tableau.Select
tableau.Sort key1:=tableau.Columns(1), key2:=tableau.Columns(4), Order1:=xlAscending
End With

'double
Set deb = tableau(1, 1)
lignes = tableau.Columns(1).Rows.Count
For n = 1 To lignes - 1
If tableau(n, 1) = tableau(n + 1, 1) And tableau(n, 4) = tableau(n + 1, 4) Then
MsgBox tableau(n + 1, 1).Address
tableau(n + 1, 1).EntireRow.Delete
n = n - 1
lignes = lignes - 1
Else

End If
Next
'fichiers
With Sheets("base")
Set tableau = .Range(.Cells(2, 1), .Cells(.Range("a2").End(xlDown).Row, 8))
tableau.Select
End With
For Each i In tableau.Columns(1).Rows
fichier = i & " phase N° " & i.Offset(0, 3) & ".xlsm"
Set fso = CreateObject("scripting.filesystemobjet")
If fso.fileexists(chemin & fichier) = False Then
i.EntireRow.Delete
Next
End Sub

 

[job75]

Re : test liste si doublon

Bonjour ngexcel, le forum,

La difficulté c'est qu'en colonne D il peut y avoir des espaces ou ne pas y en avoir.

Mais en faisant attention on peut y remédier :

Sub oterdoublons()
Dim chemin$, P As Range, t, i&, x$, y$, z$, fich$
Dim test1 As Boolean, test2 As Boolean, test3 As Boolean
chemin = ThisWorkbook.Path & "\" 'à adapter
Application.ScreenUpdating = False
Set P = [A1].CurrentRegion.Resize(, 8)
P.Sort [A1], xlAscending, [D1], , xlAscending, [H1], xlDescending, Header:=xlYes
t = P 'matrice, plus rapide
For i = UBound(t) To 2 Step -1
  x = Trim(t(i, 1))
  test1 = x = Trim(t(i - 1, 1))
  y = Replace(t(i, 4), " ", "")
  test2 = y = Replace(t(i - 1, 4), " ", "")
  z = Replace(y, "-", "*-*")
  fich = Dir(chemin & x & " *phase*N°*" & z & "*.xls*")
  test3 = True
  Do While fich <> ""
    fich = LCase(Replace(fich, " ", ""))
    If fich Like "*phasen°" & y & ".xls*" Then test3 = False: Exit Do
    fich = Dir
  Loop
  If test1 And test2 Or test3 Then P(i, 1) = Empty
Next
P.Sort [A1], xlAscending, Header:=xlYes 'lignes vides en bas du tableau
On Error Resume Next 's'il n'y a pas de ligne vide
P.Columns(1).SpecialCells(xlCellTypeBlanks).Resize(, 8).Delete xlUp
End Sub

Attention en testant, si aucun fichier n'est trouvé dans le répertoire, toutes les lignes seront supprimées...

Edit 1 : hello sousou, pas vu.

Edit 2 : P(i, 1) = Empty plus simple que P.Rows(i).ClearContents

A+

 

[ngexcel]

Re : test liste si doublon

2356300020 E FOND 10 0 6 2 06/06/2014 06/06/2014
2356300020 E FOND 050-080-160 0 0 6 06/06/2014 06/06/2014

dans ta macro job75 quand j ai deux lignes comme ca
ca devrait me les garder alors que ta macro me détruit une ligne j ai bien deux ref identique mais la colonne 4 est differente

merci sousou je test après ta macro

peux ton tester plus les lignes complète si différente on garde si non on detruit

 

[ngexcel]

Re : test liste si doublon

pour sousou
j ai une erreur
public const chemin = "C:\test fittt"

 

[job75]

Re : test liste si doublon

Re,

Ne pas oublier qu'une ligne est supprimée si le fichier correspondant n'existe pas...

De plus dans vos exemples post #4 il y aurait 9 colonnes alors qu'au post #1 votre fichier en a 8...

A+

 

[ngexcel]

Re : test liste si doublon

re bonjour
je confirme il y a bien 8 colonnes
cela fonctionne si un fichier est supprimé la ligne est supprimé ca ok

ce qui bug c'est que je peux avoir en colonne 1 la reference sur plusieurs ligne avec en colonne 4 différentes phase
et la CA ne doit pas me les supprimer

la suppression doit se faire si uniquement la ligne complète est en double

et bien sur un fin de macro un tri croissant de la colonne 1

 

[job75]

Re : test liste si doublon

Re,

ce qui bug c'est que je peux avoir en colonne 1 la reference sur plusieurs ligne avec en colonne 4 différentes phase

On avait bien compris et c'est bien ce que fait ma macro du post #3

la suppression doit se faire si uniquement la ligne complète est en double

Sauf la date en colonne H je pense, alors voyez cette nouvelle macro :

Sub OterDoublonsLignes()
Dim chemin$, P As Range, t, i&, j As Byte, a(1 To 7), b(1 To 7)
Dim x$, test1 As Boolean, test2 As Boolean, fich$
chemin = ThisWorkbook.Path & "\" 'à adapter
Application.ScreenUpdating = False
Set P = [A1].CurrentRegion.Resize(, 8)
P.Sort [A1], xlAscending, [D1], , xlAscending, [H1], xlDescending, Header:=xlYes
t = P 'matrice, plus rapide
For i = UBound(t) To 2 Step -1
  For j = 1 To 7
    a(j) = Trim(t(i, j)): b(j) = Trim(t(i - 1, j))
  Next
  a(4) = Replace(a(4), " ", ""): b(4) = Replace(b(4), " ", "")
  x = Replace(a(4), "-", "*-*")
  test1 = Join(a) = Join(b)
  test2 = True
  fich = Dir(chemin & a(1) & " *phase*N°*" & x & "*.xls*")
  Do While fich <> ""
    fich = LCase(Replace(fich, " ", ""))
    If fich Like "*phasen°" & a(4) & ".xls*" Then test2 = False: Exit Do
    fich = Dir
  Loop
  If test1 Or test2 Then P(i, 1) = Empty
Next
P.Sort [A1], xlAscending, Header:=xlYes 'lignes vides en bas du tableau
On Error Resume Next 's'il n'y a pas de ligne vide
P.Columns(1).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
t = ActiveSheet.UsedRange 'mise à jour de l'ascenseur vertical
End Sub

Pour tester téléchargez les 4 fichiers joints dans le même dossier (le bureau par exemple).

A+

 

[ngexcel]

Re : test liste si doublon

merci cela fonctionne
j ai juste les 2 premières lignes qui se tri pas

2500016269..............................
0298340080..........................

bizarre j ai bien les fichiers dans le repertoire

j ai essayé avec la commande données trier ça marche pas ? peux être un problème de format

 

[job75]

Re : test liste si doublon

j ai juste les 2 premières lignes qui se tri pas

2500016269..............................
0298340080..........................

bizarre j ai bien les fichiers dans le repertoire

Moi aussi et ça marche, voir les fichiers joints.

 

[ngexcel]

Re : test liste si doublon

Je regarde demain
Merci de votre aide
Je vous tiens informe de l évolution

 

[job75]

Re : test liste si doublon

Re,

Si en colonne D, en plus des espaces, il faut s'occuper des zéros non significatifs :

Sub OterDoublonsLignes()
Dim chemin$, P As Range, t, i&, j As Byte, a(1 To 7), b(1 To 7)
Dim x$, test1 As Boolean, test2 As Boolean, fich$
chemin = ThisWorkbook.Path & "\" 'à adapter
Application.ScreenUpdating = False
Set P = [A1].CurrentRegion.Resize(, 8)
P.Sort [A1], xlAscending, [D1], , xlAscending, [H1], xlDescending, Header:=xlYes
t = P 'matrice, plus rapide
For i = UBound(t) To 2 Step -1
  For j = 1 To 7
    a(j) = Trim(t(i, j)): b(j) = Trim(t(i - 1, j))
  Next
  a(4) = ZerosNonSignificatifs(Replace(a(4), " ", ""))
  b(4) = ZerosNonSignificatifs(Replace(b(4), " ", ""))
  x = Replace(a(4), "-", "*-*")
  test1 = Join(a) = Join(b)
  test2 = True
  fich = Dir(chemin & a(1) & " *phase*N°*" & x & "*.xls*")
  Do While fich <> ""
    fich = ZerosNonSignificatifs(LCase(Replace(fich, " ", "")))
    If fich Like "*phasen°" & a(4) & ".xls*" Then test2 = False: Exit Do
    fich = Dir
  Loop
  If test1 Or test2 Then P(i, 1) = Empty
Next
P.Sort [A1], xlAscending, Header:=xlYes 'lignes vides en bas du tableau
On Error Resume Next 's'il n'y a pas de ligne vide
P.Columns(1).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
t = ActiveSheet.UsedRange 'mise à jour de l'ascenseur vertical
End Sub

Function ZerosNonSignificatifs(t$)
Dim i%
t = Chr(1) & t
For i = 2 To Len(t)
  If Not Mid(t, i - 1, 1) Like "#" And Mid(t, i, 1) = "0" _
    Then t = Application.Replace(t, i, 1, Chr(1))
Next
ZerosNonSignificatifs = Replace(t, Chr(1), "")
End Function

Fichier (3) et les autres.

Edit : la durée d'exécution est augmentée mais de peu.

Avec 50000 lignes sur Win XP Excel 2003 :

- fichier (2) => 15,6 secondes.

- fichier (3) => 17,3 secondes.

Ce qui prend du temps c'est l'effacement des cellules en colonne A.

Bonne nuit et A+

 

[job75]

Bonjour ngexcel, le forum,

En utilisant un tableau VBA et une colonne auxiliaire les durées d'exécution sont notablement réduites.

Toujours avec 50000 lignes :

- fichier (2 bis) => 7,9 secondes

- fichier (3 bis) => 9,6 secondes.

Edit : pour le tri en colonne A j'ai ajouté DataOption1:=xlSortTextAsNumbers

Bonne journée.

 

[job75]

Re : test liste si doublon

Re,

J'avais mal interprété votre post #9 :

j ai juste les 2 premières lignes qui se tri pas

2500016269..............................
0298340080..........................

2500016269 est un nombre et se positionne donc avant 0298340080 qui est un texte, c'est normal.

La colonne A étant au format texte, il suffit de revalider 2500016269 pour le transformer en texte.

Mais on peut aussi spécifier que le tri doit considérer les textes comme des nombres :

P.Sort [A1], xlAscending, [D1], , xlAscending, [H1], xlDescending, _
  Header:=xlYes, DataOption1:=xlSortTextAsNumbers

Je modifie les fichiers (2 bis) et (3 bis) en conséquence.

A+

 

[ngexcel]

Re : test liste si doublon

bonjour et merci

j ai pas testé
j ai un problème quand je lance la macro OterDoublonsLignes du fichier suivfitt a partir d un autre fichier après exécution de la macro
le fichier se fermé avant et maintenant il reste ouvert.
voici la macro qui me lance la macro oterdoublonslignes


Public tbl As Variant

Sub ouvreform()
Workbooks.Open Filename:="C:\test fitt\SuiviFitt.xlsm"
Range("J6").Select
Application.Run "SuiviFitt.xlsm!OterDoublonsLignes"
ActiveWorkbook.Save
ActiveWindow.Close
UserForm1.Show
End Sub

Public Sub ChercheFichier()
chemin = ThisWorkbook.Path & "\"
fichier = "SuiviFitt.xlsm"
Workbooks.Open Filename:=chemin & fichier
tbl = ActiveWorkbook.Worksheets("base").Range("A2:I" & Worksheets("base").Range("A65536").End(xlUp).Row)
ActiveWorkbook.Close False
End Sub