Conserver les doublons excel

[nyto01]

Bonjour,
Je souhaiterai une solution pour extraire uniquement les valeurs en doublons en rose de la colonne Lien avec les données de la ligne correspondante.
merci pour vos réponses
Tony

 

[eddy1975]

Bonjour nyto01

Un exemple par filtre personnalisé par couleur. Ne pas modifier la MFC des doublons.

@+

 

[pierrejean]

Bonjour
Un esssai en Vba

 

[nyto01]

Bonjour
Un esssai en Vba

 

[nyto01]

Bonjour,
Merci pour votre aide, votre macro marche très bien.
Seriez vous intéressé pour me développer cette macro sous excel dans un cadre plus complexe
Dans l'affirmative, je vous donnerai les réf de ma société et nous prendrons contact directement
Cordialement
Antoine D

 

[nyto01]

Merci PierreJean pour votre aide,
Seriez vous intéressé pour me développer cette macro sous excel dans un cadre plus complexe?
Cordialement
Antoine D

 

[job75]

Bonjour nyto01, eddy1975, Pierre,

Seriez vous intéressé pour me développer cette macro sous excel dans un cadre plus complexe?

pierrejean il est sûrement comme moi il est âpre au gain, c'est cher de l'heure

Antoine, pour économiser des sous, vaudrait mieux vous mettre au boulot.

A+

 

[job75]

Re,

Avec le filtre avancé le tableau de la 1ère feuille peut avoir été trié sur n'importe quelle colonne :

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Target.Address <> "$D$1" Then Exit Sub 'cellule D1 à adapter
Cancel = True
Application.ScreenUpdating = False
[K2] = "=COUNTIF(D:D,D2)>1" 'critère de filtrage, cellule K2 à adapter
[D1].CurrentRegion.AdvancedFilter xlFilterInPlace, [K1:K2]
With Sheets("Résultat")
  .Cells.Delete 'RAZ
  [D1].CurrentRegion.Copy .[A1]
  .Columns.AutoFit 'ajustement largeur
  .Activate
End With
[K2] = "" 'RAZ
[D1].CurrentRegion.AdvancedFilter xlFilterInPlace, "" 'RAZ
End Sub

Fichier joint.

Antoine ça m'a bien pris 5 minutes, à 1200 €/h vous me devez 100 €.

Bonne nuit.

 

[job75]

Bonjour Antoine, le forum,

Ceci est nettement plus cher :

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Target.Address <> [lien].Address Then Exit Sub 'cellule nommée
Cancel = True
Application.ScreenUpdating = False
With [lien].CurrentRegion
  .Cells(2, .Columns.Count + 1).FormulaR1C1 = _
    "=COUNTIF(C" & [lien].Column & ",RC" & [lien].Column & ")>1" 'critère de filtrage
  .AdvancedFilter xlFilterInPlace, .Cells(1, .Columns.Count + 1).Resize(2)
  .Cells(2, .Columns.Count + 1) = "" 'RAZ
  With Feuil2 'CodeName de la feuille "Résultat"
    .Cells.Delete 'RAZ
    [lien].CurrentRegion.Copy .[A1]
    .[A1].ClearComments
    .Columns.AutoFit 'ajustement largeur
    .Activate
  End With
  .AdvancedFilter xlFilterInPlace, "" 'RAZ
End With
End Sub

Le tableau source peut être n'importe où et il n'y a rien à adapter.

Fichier (2).

Bonne journée.

 

[Si...]

Bonjour

Un peu moins cher avec des Tableaux d’onglet .

Private Sub Worksheet_Activate()
  Application.ScreenUpdating = 0: Application.DisplayAlerts = 0
  [Tb].Copy [Tbb]
  [H3].FormulaR1C1 = "=COUNTIF([lien],[@lien])"
  [Tbb].AutoFilter 8, 1
  [Tbb].SpecialCells(12).Rows.Delete
  [Tbb].Columns(8).Delete
  [Tbb].AutoFilter
End Sub

Private Sub Worksheet_Deactivate()
  If [Tbb].Item(1, 1) <> "" Then [Tbb].Delete
End Sub

La seconde macro permet, en plus de la réinitialisation, d’alléger le fichier pour une dépense dérisoire.

 

[job75]

Re, salut Si...,

Le calcul des formules utilisant la fonction NB.SI prend beaucoup de temps sur un grand tableau.

Cette macro est très rapide car elle utilise le Dictionary et un tableau VBA :

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Target.Address <> [lien].Address Then Exit Sub 'cellule nommée
Dim tablo, ncol%, d As Object, i&, n&, lig&, j%
Cancel = True
tablo = [lien].CurrentRegion.Offset(1)
ncol = UBound(tablo, 2)
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare 'la casse est ignorée
For i = 1 To UBound(tablo) - 1
  If d.exists(tablo(i, 1)) Then
    n = n + 1
    If IsNumeric(d(tablo(i, 1))) Then '1er des doublons
      lig = d(tablo(i, 1))
      d(tablo(i, 1)) = ""
      For j = 1 To ncol
        tablo(n, j) = tablo(lig, j)
      Next j
      n = n + 1
    End If
    For j = 1 To ncol
      tablo(n, j) = tablo(i, j)
    Next j
  Else
    d(tablo(i, 1)) = i 'mémorise la ligne
  End If
Next i
With Feuil2 'CodeName de la feuille "Résultat"
  .Cells.Delete 'RAZ
  [lien].CurrentRegion.Rows(1).Copy .[A1] 'titres
  .[A1].ClearComments
  .Columns(4).NumberFormat = "@" 'format Texte à cause des $2
  If n Then .[A2].Resize(n, ncol) = tablo 'restitution
  .Columns(4).NumberFormat = "General"
  .[A2].CurrentRegion.Borders.Weight = xlHairline 'bordures
  .[A:A].HorizontalAlignment = xlLeft
  .Columns.AutoFit 'ajustement largeur
  .Activate
End With
End Sub

Bien sûr ici les formats (et la MFC) ne sont pas copiés.

Fichier (3).

Pour comparer les méthodes (2) et (3) voyez les 2 fichiers de test avec 10 800 lignes.

A+

 

[job75]

Re,

Je viens de remarquer qu'avec la version (3) les $2 de la 4ème colonne (Article) étaient convertis en 2 € (valeur 2 et cellule au format monétaire €).

Pour éviter ce (curieux) phénomène il suffit avant la restitution de mettre la 4ème colonne au format Texte.

J'ai complété la macro.

A+

 

[job75]

Re,

Voici dans les mêmes conditions les fichiers tests pour les macros de pierrejean et de Si...

Bien noter qu'avec 10 800 lignes ce ne sont pas de très gros fichiers...

A+

 

[job75]

Bonjour le fil, le forum,

Remarquez que la méthode de pierrejean est presqu'aussi rapide que le Dictionary si l'on regroupe les lignes à supprimer :

Sub test()
t = Timer
Application.ScreenUpdating = False
For n = 2 To Cells(Rows.Count, 4).End(xlUp).Row
  If Cells(n, 4) <> Cells(n + 1, 4) And Cells(n, 4) <> Cells(n - 1, 4) Then Cells(n, 3) = 1 'repère
Next
[C:J].Sort [C1] 'tri pour regrouper les 1
On Error Resume Next
[C:C].SpecialCells(xlCellTypeConstants, 1).EntireRow.Delete
[D1].CurrentRegion.Borders(xlInsideHorizontal).Weight = xlHairline
With ActiveSheet.UsedRange: End With 'actualise la barre de défilement verticale
Application.ScreenUpdating = True
MsgBox "Durée " & Format(Timer - t, "0.00 \s")
End Sub

Bien sûr il faut qu'au départ les lignes aient été classées dans le bon ordre.

Bonne journée.

 

[job75]

Bonjour le fil, le forum,

Grâce à la solution de pierrejean voici à mon avis la meilleure méthode :

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Target.Address <> [lien].Address Then Exit Sub 'cellule nommée
Dim tablo, i&, n&
Cancel = True
Application.ScreenUpdating = False
If FilterMode Then ShowAllData 'si la feuille est filtrée
With Feuil2 'CodeName de la feuille "Résultat"
  [lien].CurrentRegion.Copy .[A1]
  .[A1].ClearComments
  .[A:A].Insert 'colonne auxiliaire
  .[A1] = 1
  With .[A1].CurrentRegion
    .Columns(1).DataSeries 'numérotation de l'ordre initial
    If .Parent.ListObjects.Count Then .Parent.ListObjects(1).Resize .Cells 'tableau Excel redimensionné
    .Sort .Columns(2), Header:=xlYes 'classement préalable
    tablo = .Resize(.Rows.Count + 1, 2) 'matrice, plus rapide
    For i = 2 To UBound(tablo) - 1
      If tablo(i, 2) <> tablo(i + 1, 2) And tablo(i, 2) <> tablo(i - 1, 2) Then n = n + 1: tablo(i, 1) = "" 'repère
    Next
    .Columns(1) = tablo 'restitution des repères
    .Sort .Columns(1), xlAscending, Header:=xlYes 'tri pour regrouper les vides et rétablir l'ordre initial
    If n Then .Rows(.Rows.Count - n + 1).Resize(n).Delete xlUp 'suppression des lignes
  End With
  [lien].CurrentRegion.Copy
  .[B1].PasteSpecial xlPasteColumnWidths '.Columns.AutoFit prend trop de temps sur un tableau Excel
  .[A:A].Delete 'suppression de la colonne auxiliaire
  With .UsedRange: End With 'actualise les barres de défilement
  Application.Goto .[A1], True 'cadrage
End With
End Sub

Elle est aussi rapide que le Dictionary et en plus les formats (et la MFC) sont copiés.

Et elle fonctionne très bien sur les tableaux Excel.

Edit : .Columns.AutoFit prend trop de temps sur un tableau Excel.

Fichiers joints.

A+