Éclater un tableau de données en plusieurs pavés pour dissocie les doublons/triplons/

[LPandre]

Bonjour,

Je souhaite une macro pour gérer ça :
J'ai un onglet base qui contient x enregistrements
L'identifiant est le Matricule
Il peu y avoir des doublons de matricule car un matricule peut avoir plusieurs type de libellé, et/ou pour un même libellé plusieurs montants.

Je souhaite avoir à la fin de la macro sur un deuxième onglet un regroupement des "simplons" + la première ligne des doublons.
Ensuite séparé par une ligne vide, les doublons (ou ce qui est la deuxième ligne des "triplons")
Ensuite séparé par une ligne vide, les "triplons" (ou ce qui est la troisième ligne des "quatrons"
Ensuite séparé par une ligne les "quatrons"

Normalement il ne peut y avoir plus de 4 lignes pour un utilisateur.
Il se peut aussi que parfois il n'y ai aucun doublons / triplons, etc.
L'onglet source n'est pas trié au départ, s'il le faut ce n'est pas bloquant.

Voir fichier joint pour l'exemple

Merci.

 

[job75]

Re : Éclater un tableau de données en plusieurs pavés pour dissocie les doublons/trip

Bonjour LPandre, le forum,

Voyez le fichier joint et cette macro dans le code de la feuille "Résultat" :

Private Sub Worksheet_Activate()
Dim saut As Byte, t, ncol%, d As Object, i&, x$, ntab&, rest(), n&, j%
'---préparation et numérotation des lignes---
saut = 1 'nombre de lignes à sauter, à adapter
With Sheets("Base").[A3].CurrentRegion
  t = .Resize(, .Columns.Count + 1) '1 colonne de plus
End With
ncol = UBound(t, 2)
Set d = CreateObject("Scripting.Dictionary")
For i = 2 To UBound(t)
  x = CStr(t(i, 2)) 'matricule
  d(x) = d(x) + 1 'rang des doublons
  t(i, ncol) = d(x) 'numérotation en dernière colonne
Next i
If d.Count = 0 Then GoTo 1 'si le tableau est vide
ntab = Application.Max(d.items) 'nombre de tableaux à créer
ReDim rest(1 To UBound(t) + saut * ntab, 1 To ncol - 1)
'---création des tableaux---
For ntab = 1 To ntab
  For i = 2 To UBound(t)
    If t(i, ncol) = ntab Then
      n = n + 1
      For j = 1 To ncol - 1
        rest(n, j) = t(i, j)
      Next j
    End If
  Next i
  n = n + saut 'sauts de lignes
Next ntab
'---restitution---
[A4].Resize(n, ncol - 1) = rest
1 Rows(n + 4 & ":" & Rows.Count).Delete
End Sub

La macro se déclenche quand on active la feuille.

Aucun tri du tableau n'est nécessaire.

Bonne journée.

 

[LPandre]

Re : Éclater un tableau de données en plusieurs pavés pour dissocie les doublons/trip

Merci ! Bravo !

 

[job75]

Re : Éclater un tableau de données en plusieurs pavés pour dissocie les doublons/trip

Re,

Si l'on veut que chaque tableau soit trié sur les matricules il faut prendre des précautions.

En effet des matricules peuvent être des nombres (cellule B4 de la feuille "Base"), d'autres des textes.

Il faut alors, quand c'est possible, convertir les textes en nombres avec CDbl :

Private Sub Worksheet_Activate()
Dim saut As Byte, t, ncol%, d As Object, i&, x$, ntab&, rest(), n&, j%, a As Range
'---préparation et numérotation des lignes---
saut = 1 'nombre de lignes à sauter, à adapter
With Sheets("Base").[A3].CurrentRegion
  t = .Resize(, .Columns.Count + 1) '1 colonne de plus
End With
ncol = UBound(t, 2)
Set d = CreateObject("Scripting.Dictionary")
For i = 2 To UBound(t)
  x = CStr(t(i, 2)) 'matricule
  If x <> "" Then
    If IsNumeric(x) Then t(i, 2) = CDbl(x) 'conversion
    d(x) = d(x) + 1 'rang des doublons
    t(i, ncol) = d(x) 'numérotation en dernière colonne
  End If
Next i
If d.Count = 0 Then GoTo 1 'si le tableau est vide
ntab = Application.Max(d.items) 'nombre de tableaux à créer
ReDim rest(1 To UBound(t) + saut * ntab, 1 To ncol - 1)
'---création des tableaux---
For ntab = 1 To ntab
  For i = 2 To UBound(t)
    If t(i, ncol) = ntab Then
      n = n + 1
      For j = 1 To ncol - 1
        rest(n, j) = t(i, j)
      Next j
    End If
  Next i
  n = n + saut 'sauts de lignes
Next ntab
'---restitution et tri---
Application.ScreenUpdating = False
With [A4].Resize(n, ncol - 1)
  .Value = rest
  Set a = .Columns(2).SpecialCells(xlCellTypeConstants)
  For Each a In a.Areas
    a.EntireRow.Sort a, xlAscending, Header:=xlNo 'tri
  Next
End With
1 Rows(n + 4 & ":" & Rows.Count).Delete
End Sub

Fichier joint.

Edit : bonjour Efgé (Fred), heureux de te croiser

A+

 

[Efgé]

Re : Éclater un tableau de données en plusieurs pavés pour dissocie les doublons/trip

Bonjour LPandre, Bonjour Job

Merci pour :

 Application.Max(d.items)

J'aurais pas pensé

Cordialement

 

[BOISGONTIER]

Re : Éclater un tableau de données en plusieurs pavés pour dissocie les doublons/trip

Bonjour,

Sub Doublons()
  a = Range("A2:H" & [A65000].End(xlUp).Row).Value
  Set d = CreateObject("scripting.dictionary")
  For i = LBound(a) To UBound(a)
    d(CStr(a(i, 2))) = d(CStr(a(i, 2))) + 1
    a(i, UBound(a, 2)) = d(CStr(a(i, 2)))
  Next i
  Set f = Sheets("result")
  f.Cells.Clear:  [A1:H1].Copy f.[A1]
  f.[a2].Resize(UBound(a), UBound(a, 2)) = a
  f.[a2].Sort key1:=f.[h2], key2:=f.[b2], Header:=yes
  For i = f.[A65000].End(xlUp).Row To 3 Step -1
    If f.Cells(i, 8) <> f.Cells(i - 1, 8) Then f.Rows(i).Insert
  Next i
End Sub

JB

 

[job75]

Re : Éclater un tableau de données en plusieurs pavés pour dissocie les doublons/trip

Bonjour JB,

Avec un tri sur les numéros 1 2 3 4 c'est en effet bien plus simple et plus rapide.

Autrement c'est le même principe : stockage de ces numéros dans une colonne supplémentaire du tableau VBA.

A+