mettre les valeurs identiques de plusieurs colonnes sur la même ligne

B

bouclette21

XLDnaute Nouveau
Bonjour,
Je viens solliciter votre aide !!
Je traite actuellement des fichiers avec beaucoup de données et il me faut faire un tri et je n'y parviens pas seule.
Pour plus de simplicité j'ai joint un morceau de fichier.
Les données des colonnes A, B, et C sont liées, elles doivent rester sur la même ligne, ainsi que celles des colonnes D, E et F ; G, H et I ; J, K et L ; M, N et O.
Je voudrais que les valeurs identiques des colonnes A, D, G, J et M se retrouvent sur la même ligne, sans perdre les données rattachées. :confused:
Pourriez-vous m'aider s'il vous plait ??
Je vous remercie d'avance !

PS : je ne sais pas programmer !! :)
 

Pièces jointes

  • test tri.xlsx
    10.5 KB · Affichages: 72
  • test tri.xlsx
    10.5 KB · Affichages: 79
  • test tri.xlsx
    10.5 KB · Affichages: 85
Trier par date Trier par votes
H

homepyrof53

XLDnaute Occasionnel
Re : mettre les valeurs identiques de plusieurs colonnes sur la même ligne

Bonjour,

Voici une version, le résultat est sur la feuille 2

Code: 
Option Explicit
Sub essai()
Dim Tab_Datas
Set Tab_Datas = CreateObject("scripting.dictionary")
Dim L1, C1, cle, tmp
'-------------------------------------------------------------
'                      Lecture des données
'-------------------------------------------------------------
Sheets("Feuil1").Select
L1 = 1
While Cells(L1, 1) <> ""
    For C1 = 1 To 13 Step 3
        cle = Cells(L1, C1)
        If Tab_Datas.exists(cle) = False Then
            Tab_Datas(cle) = Array("", "", "", "", "", "", "", "", "", "")
        End If
        tmp = Tab_Datas(cle)
        Select Case C1
            Case 1
                tmp(0) = Cells(L1, C1 + 1)
                tmp(1) = Cells(L1, C1 + 2)
            Case 4
                tmp(2) = Cells(L1, C1 + 1)
                tmp(3) = Cells(L1, C1 + 2)
            Case 7
                tmp(4) = Cells(L1, C1 + 1)
                tmp(5) = Cells(L1, C1 + 2)
            Case 10
                tmp(6) = Cells(L1, C1 + 1)
                tmp(7) = Cells(L1, C1 + 2)
            Case 13
                tmp(8) = Cells(L1, C1 + 1)
                tmp(9) = Cells(L1, C1 + 2)
        End Select
        Tab_Datas(cle) = tmp
    Next C1
    L1 = L1 + 1
Wend
'-------------------------------------------------------------
'                      Ecriture du résultat
'-------------------------------------------------------------
Sheets("Feuil2").Select
L1 = 2
For Each cle In Tab_Datas
    Cells(L1, 1) = cle
    tmp = Tab_Datas(cle)
    Cells(L1, 2) = tmp(0)
    Cells(L1, 3) = tmp(1)
    Cells(L1, 4) = tmp(2)
    Cells(L1, 5) = tmp(3)
    Cells(L1, 6) = tmp(4)
    Cells(L1, 7) = tmp(5)
    Cells(L1, 8) = tmp(6)
    Cells(L1, 9) = tmp(7)
    Cells(L1, 10) = tmp(8)
    Cells(L1, 11) = tmp(9)
    L1 = L1 + 1
Next

End Sub
 
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Re : mettre les valeurs identiques de plusieurs colonnes sur la même ligne

Bonjour bouclette21, bienvenue sur XLD,

Bravo, c'est un très joli problème pour un 1er post, j'ai mis un Like :)

Voyez le fichier joint avec cette macro :

Code: 
Sub Rangement()
Dim t1, mini&, maxi&, ub&, t2()
Dim j%, i&, v&, sup As Range
t1 = Feuil1.UsedRange 'CodeName de la feuille
mini = Application.Min(t1) - 1
maxi = Application.Max(t1)
ub = UBound(t1)
ReDim t2(1 To maxi - mini, 1 To UBound(t1, 2))
On Error Resume Next 'si cellules vides
For j = 1 To UBound(t1, 2) Step 3
  For i = 1 To ub
    v = t1(i, j) - mini
    t2(v, j) = t1(i, j)
    t2(v, j + 1) = t1(i, j + 1)
    t2(v, j + 2) = t1(i, j + 2)
  Next
Next
On Error GoTo 0
With Feuil2 'CodeName
  '---restitution---
  .Cells.ClearContents 'RAZ
  .[A1].Resize(UBound(t2), UBound(t2, 2)) = t2
  '---suppression des lignes vides---
  For i = 1 To UBound(t2)
    If Application.CountA(.Rows(i)) = 0 Then _
      Set sup = Union(IIf(sup Is Nothing, .Rows(i), sup), .Rows(i))
  Next
  If Not sup Is Nothing Then sup.Delete
  .Activate
End With
End Sub

Nota 1 : tous les nombres doivent être des nombres entiers.

Nota 2 : la différence entre le maximum et le minimum ne doit pas dépasser le nombre de lignes de la feuille, c'est à dire 65536 sur Excel 2003 et 1048576 sur Excel 2007/2013.

Nota 3 : s'il y a des doublons dans une même colonne de nombres seule la dernière valeur est conservée.

Edit : salut homepyrof53, pas rafraîchi.

A+
 

Pièces jointes

  • test tri(1).xls
    52.5 KB · Affichages: 48
Dernière édition:
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Re : mettre les valeurs identiques de plusieurs colonnes sur la même ligne

Re,

J'ai ajouté On Error Resume Next dans la macro précédente.

En effet s'il y a des cellules vides dans les colonnes A D G J M l'indice v est négatif et donc "n'appartient pas à la sélection".

A+
 
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Re : mettre les valeurs identiques de plusieurs colonnes sur la même ligne

Re,

Sur un grand tableau, la suppression des lignes vides par formules dans une colonne auxiliaire sera plus rapide.

Le tri des valeurs d'erreur accélère la suppression :

Code: 
Sub Rangement()
Dim t1, mini&, maxi&, ub1&, ub2%, t2(), j%, i&, v&
t1 = Feuil1.UsedRange 'CodeName de la feuille
mini = Application.Min(t1) - 1
maxi = Application.Max(t1)
ub1 = UBound(t1)
ub2 = UBound(t1, 2)
ReDim t2(1 To maxi - mini, 1 To ub2)
On Error Resume Next 'si cellules vides
For j = 1 To ub2 Step 3
  For i = 1 To ub1
    v = t1(i, j) - mini
    t2(v, j) = t1(i, j)
    t2(v, j + 1) = t1(i, j + 1)
    t2(v, j + 2) = t1(i, j + 2)
  Next
Next
On Error GoTo 0
'---feuille de restitution---
With Feuil2 'CodeName
  .Cells.ClearContents 'RAZ
  With .[A1].Resize(UBound(t2), ub2)
    .Cells = t2
    '---suppression des lignes vides---
    i = ub2 + 1 'n° de la colonne auxiliaire
    .Columns(i).FormulaR1C1 = "=LN(COUNTA(RC1:RC[-1])>0)"
    .Columns(i) = .Columns(i).Value 'suppression des formules
    .Resize(, i).Sort .Columns(i), xlAscending, Header:=xlNo 'tri
    On Error Resume Next 'si aucune valeur d'erreur
    .Columns(i).SpecialCells(xlCellTypeConstants, 16).EntireRow.Delete
    .Columns(i).ClearContents
  End With
  .Activate
End With
End Sub
Fichier (2).

A+
 

Pièces jointes

  • test tri(2).xls
    55 KB · Affichages: 49
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Re : mettre les valeurs identiques de plusieurs colonnes sur la même ligne

Bonjour bouclette21, le forum,

En supprimant les lignes vides dans le tableau VBA on risque beaucoup moins de dépasser les limites de la feuille :

Code: 
Sub Rangement()
Dim t1, mini&, maxi&, ub1&, ub2%, ub3%, t2(), j%, i&, v&, n&
t1 = Feuil1.UsedRange 'CodeName de la feuille
mini = Application.Min(t1) - 1
maxi = Application.Max(t1)
ub1 = UBound(t1)
ub2 = UBound(t1, 2)
ub3 = ub2 + 1
ReDim t2(1 To maxi - mini, 1 To ub3)
On Error Resume Next 'si cellules vides
For j = 1 To ub2 Step 3
  For i = 1 To ub1
    v = t1(i, j) - mini
    t2(v, j) = t1(i, j)
    t2(v, j + 1) = t1(i, j + 1)
    t2(v, j + 2) = t1(i, j + 2)
    t2(v, ub3) = True
  Next
Next
On Error GoTo 0
'--- suppression des lignes vides---
For i = 1 To UBound(t2)
  If t2(i, ub3) Then
    n = n + 1
    For j = 1 To ub2
      t2(n, j) = t2(i, j)
    Next
  End If
Next
'---feuille de restitution---
With Feuil2 'CodeName
  .Cells.ClearContents 'RAZ
  .[A1].Resize(n, ub2) = t2
  .Activate
End With
End Sub
L'instruction t2(v, ub3) = True facilite grandement les choses.

Fichier (3).

Edit : sur Excel 2003 la macro s'exécute en 0,015 s contre environ 0,30 s dans les versions (1) et (2).

Et même en mettant 1603492 en A1 la durée n'est que 0,5 s.

A+
 

Pièces jointes

  • test tri(3).xls
    55 KB · Affichages: 45
Dernière édition:
Vote positif 0 Vote négatif
B

bouclette21

XLDnaute Nouveau
Re : mettre les valeurs identiques de plusieurs colonnes sur la même ligne

Merciiii !! vous ne pouvez pas savoir comme je suis contente d'avoir de l'aide !! et en plus très facile pour moi qui n'y connais rien ! merci infiniment, je vais tester cela tout de suite sur mes fichiers de 56000 lignes !
Vous êtes formidables !! :eek:
 
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Re : mettre les valeurs identiques de plusieurs colonnes sur la même ligne

Re,

Noter que s'il y avait des nombres dans d'autres colonnes que A D G J M il faudrait utiliser :

Code: 
Sub Rangement()
Dim t1, mini&, maxi&, ub1&, ub2%, ub3%, t2(), j%, i&, v&, n&
With Feuil1 'CodeName de la feuille
  t1 = .UsedRange
  With Union(.[A:A], .[D:D], .[G:G], .[J:J], .[M:M])
    mini = Application.Min(.Cells) - 1
    maxi = Application.Max(.Cells)
  End With
End With
ub1 = UBound(t1)
ub2 = UBound(t1, 2)
ub3 = ub2 + 1
ReDim t2(1 To maxi - mini, 1 To ub3)
On Error Resume Next 'si cellules vides
For j = 1 To ub2 Step 3
  For i = 1 To ub1
    v = t1(i, j) - mini
    t2(v, j) = t1(i, j)
    t2(v, j + 1) = t1(i, j + 1)
    t2(v, j + 2) = t1(i, j + 2)
    t2(v, ub3) = True
  Next
Next
On Error GoTo 0
'--- suppression des lignes vides---
For i = 1 To UBound(t2)
  If t2(i, ub3) Then
    n = n + 1
    For j = 1 To ub2
      t2(n, j) = t2(i, j)
    Next
  End If
Next
'---feuille de restitution---
With Feuil2 'CodeName
  .Cells.ClearContents 'RAZ
  .[A1].Resize(n, ub2) = t2
  .Activate
End With
End Sub
Fichier (3 bis).

A+
 

Pièces jointes

  • test tri(3 bis).xls
    58.5 KB · Affichages: 42
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Re : mettre les valeurs identiques de plusieurs colonnes sur la même ligne

Re,

bouclette21 à dit:
vous avez devancé ma question ! merci
Cliquez pour agrandir...

Non, mon post #8 et la version (3 bis) c'est pour une autre question.

Toutes les versions que j'ai données fonctionnent quel que soit le nombre de colonnes.

La macro traite les nombres des colonnes A D G J M et éventuellement P S V etc...

C'est le .UsedRange initial qui pilote.

A+
 
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Re : mettre les valeurs identiques de plusieurs colonnes sur la même ligne

Re,

bouclette21 m'a prévenu par MP que la macro beugue sur :

Code: 
ReDim t2(1 To maxi - mini, 1 To ub3)
avec le message "mémoire insuffisante".

Cela se produit en effet si le nombre de lignes du tableau t2 dépasse un certain seuil : environ 2 000 000 sur les versions précédentes.

Pour y rémédier découpons le tableau.

Cette version, au lieu d'un tableau de 10 000 000 de lignes, fait 50 itérations sur un tableau de 200 000 lignes :

Code: 
Sub Rangement()
Dim Nlig&, t1, mini&, maxi&, ub1&, ub2%, ub3%
Dim mx&, t2(), j%, i&, v&, n&, iter&, decal&
Nlig = 200000 'nombre de lignes max du tableau t2, à adapter
With Feuil1 'CodeName de la feuille
  t1 = .UsedRange
  With .Range("A:A,D:D,G:G,J:J,M:M")
    mini = Application.Min(.Cells) - 1
    maxi = Application.Max(.Cells)
  End With
End With
ub1 = UBound(t1)
ub2 = UBound(t1, 2)
ub3 = ub2 + 1
Do 'itération
  mx = Application.Min(mini + Nlig, maxi)
  ReDim t2(1 To mx - mini, 1 To ub3)
  On Error Resume Next 'si v n'appartient pas à la sélection
  For j = 1 To ub2 Step 3
    For i = 1 To ub1
      v = t1(i, j) - mini
      t2(v, j) = t1(i, j)
      t2(v, j + 1) = t1(i, j + 1)
      t2(v, j + 2) = t1(i, j + 2)
      t2(v, ub3) = True
    Next
  Next
  On Error GoTo 0
  '--- suppression des lignes vides---
  n = 0
  For i = 1 To UBound(t2)
    If t2(i, ub3) Then
      n = n + 1
      For j = 1 To ub2
        t2(n, j) = t2(i, j)
      Next
    End If
  Next
  '---feuille de restitution---
 With Feuil2 'CodeName
    If iter = 0 Then .Cells.ClearContents 'RAZ
    If n Then .[A1].Offset(decal).Resize(n, ub2) = t2
    If mx = maxi Then .Activate
  End With
  '---pour la prochaine itération---
  iter = iter + 1
  decal = decal + n
  mini = mx
Loop While mx < maxi
End Sub
Fichier (4).

A+
 

Pièces jointes

  • test tri(4).xls
    73.5 KB · Affichages: 54
Dernière édition:
Vote positif 0 Vote négatif
B

bouclette21

XLDnaute Nouveau
Re : mettre les valeurs identiques de plusieurs colonnes sur la même ligne

merci beaucoup ! mais j'ai maintenant une autre erreur sur la ligne

.[A1].Offset(decal).Resize(n, ub2) = t2

message : "erreur d'execution '1004' "

PS : ne vous embêtez pas, j'ai trié mes deux fichiers grâce à vous :D
 
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Re : mettre les valeurs identiques de plusieurs colonnes sur la même ligne

Re,

Avec le test If n Then normalement ça ne doit pas beuguer :

Code: 
If n Then .[A1].Offset(decal).Resize(n, ub2) = t2
Sinon svp joignez le fichier (allégé) avec le bug, je n'aime pas rester sur un bug...

A+
 
Vote positif 0 Vote négatif

Discussions similaires

Caninge
  • Question
XL 2019 Validation de Données sur plusieurs colonnes
2
Réponses
26
Affichages
767
Caninge
Caninge
M
  • Question
XL 2013 Je voudrais que les colonnes f g et h se colorent automatiquement en fonction de la couleur de la colonne M
Réponses
2
Affichages
351
MARLIOT
M
Akortys
  • Question
Microsoft 365 RESOLU - Macro - Recherche de lignes identiques et ressortir les lignes uniques
Réponses
2
Affichages
210
Akortys
Akortys
D
  • Question
Microsoft 365 Problème de format de cellule en VBA
Réponses
11
Affichages
166
David
D
J
  • Question
Microsoft 365 extraction VBA avec formule si
Réponses
10
Affichages
327
Phil69970
Phil69970
L
  • Question
XL 2021 recherche de valeurs
Réponses
3
Affichages
139
sylvanu
sylvanu
E
  • Résolu(e)
Microsoft 365 SOMMEPROD Plusieurs colonnes
Réponses
2
Affichages
183
eric72
E
Usine à gaz
  • Résolu(e)
XL 2021 Supprimer les lignes qui contiennent des cellules vides dans les colonnes "A à M" à partir de la ligne 5
Réponses
6
Affichages
234
Usine à gaz
Usine à gaz
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
209
bedley
B
P
  • Question
Microsoft 365 INDEX EQUIV Plusieurs colonnes autre fichier
Réponses
2
Affichages
391
PhilKo
P

Membres actuellement en ligne

1 membres et 86 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
312 084
Messages
2 085 192
Membres
102 809
dernier inscrit
Sandrine83