Autres Classement colonnes en VBA

[Twisty]

Bonjour les ami(e)s,
Voilà mon problème , je souhaiterai que ma colonne D se classe par rapport à la colonne A , à cellule identique.
Mon problème, que je n'arrive pas à résoudre, c'est que chaque cellule de la colonne D , ainsi que les cellules E et F se positionnent aussi.
Et si dans ma colonne D , il n'y a aucune cellule identique se trouvant dans la colonne A , elles puissent se classer en fin de classement.
J'ai surligné en jaune les deux lignes non référencé en colonne A
Je vous remercie déjà par avance de toute l'aide que vous pourrez m'apporter.

 

[Oneida]

Bonjour,
Dans votre cas le fait de deplacer les deux lignes en cause fait que tout est dans l'ordre
Est-il possible que ce ne soit pas toujours le cas?

 

[Twisty]

Bonjour les ami(e)s,
Voilà mon problème , je souhaiterai que ma colonne D se classe par rapport à la colonne A , à cellule identique.
Mon problème, que je n'arrive pas à résoudre, c'est que chaque cellule de la colonne D , ainsi que les cellules E et F se positionnent aussi.
Et si dans ma colonne D , il n'y a aucune cellule identique se trouvant dans la colonne A , elles puissent se classer en fin de classement.
J'ai surligné en jaune les deux lignes non référencé en colonne A
Je vous remercie déjà par avance de toute l'aide que vous pourrez m'apporter.

Bonjour,
Dans votre cas le fait de deplacer les deux lignes en cause fait que tout est dans l'ordre
Est-il possible que ce ne soit pas toujours le cas?

Bonjour Oneida,
Oui malheureusement , c'est pour cela que je cherche une solution en VBA , afin que chaque gencod de la colonne D se classe suivant les gencod de la colonne A.
Et surtout merci beaucoup de votre attention

 

[Oneida]

Re,
Ok

 

[JHA]

Bonjour à tous,

Avec une colonne supplémentaire

JHA

 

[Twisty]

Bonjour JHA,
Merci beaucoup et je regarde cela de suite ...

 

[ChTi160]

Bonjour le Fil
ce que j'ai mis dans un Module standard

Option Explicit
Dim Sht As Worksheet
Dim Tab_Temp
Dim lgn As Long, L As Long, x As Long, DerLgn As Long
Sub Test()
 Set Sht = ThisWorkbook.Sheets("Feuil1")
x = 0
With Sht.Range("A1")
Tab_Temp = .Resize(.CurrentRegion.Rows.Count, .CurrentRegion.Columns.Count + 1).Value
End With
For lgn = 3 To UBound(Tab_Temp, 1)
   For L = 3 To UBound(Tab_Temp, 1)
      If Tab_Temp(L, 4) = Tab_Temp(lgn, 1) Then
        x = x + 1
          Sht.Cells(L, UBound(Tab_Temp, 2)) = lgn
            Exit For
      End If
   Next L
Next
DerLgn = Sht.Cells(Sht.Rows.Count, 6).End(xlUp).Row
With Sht.Sort
        .SortFields.Clear
        ' Ajouter la colonne 7 comme critère de tri
        .SortFields.Add Key:=Sht.Range("G3:G" & DerLgn), _
                        SortOn:=xlSortOnValues, _
                        Order:=xlAscending, _
                        DataOption:=xlSortNormal
        ' Appliquer le tri aux colonnes 4 à 7
        .SetRange Sht.Range("D2:G" & DerLgn)
        .Header = xlYes ' Si a une ligne d'en-tête
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Sht.Columns(7).ClearContents
End Sub

Jean marie
Ps : je n'ai pas regardé encore le Fichier de JHA

 

[Twisty]

Bonjour ChTi160,
Excellent et merci beaucoup.
Grande classe ... , c'est exactement ce que je désirais.
Je vous souhaite une excellente journée à vous trois.
Et encore un grand merci les amis.

​

 

[job75]

Bonjour à tous,

Il faut supposer qu'il n'y a pas de doublons en colonne A et en colonne D.

Une macro très simple si l'on ne recherche pas la rapidité :

Sub Classement()
Dim derlig&, n&, i As Variant
derlig = Application.CountA(Columns(4)) + 1
Application.ScreenUpdating = False
For n = 3 To derlig - 1
    i = Application.Match(Cells(n, 4), Columns(1), 0)
    If IsError(i) Then
        Cells(n, 4).Resize(, 3).Cut
        Cells(derlig, 4).Insert xlDown
    ElseIf i <> n Then
        Cells(n, 4).Resize(, 3).Cut
        Cells(i, 4).Insert xlDown
    End If
Next
End Sub

A+

 

[Twisty]

Bonjour job,
Oui vous avez raison , il m'arrive d'avoir des doublons en colonne D ,E et F.
Peux t'on supprimer ces doublons , mais additionner ces quantités dans la colonne F ?
Un exemple avec deux lignes grisées.
Et super votre exemple.

 

[job75]

Ma macro du post #9 ne va pas.

Si on entre XXX3601010082122 en D4 la plage D5:F5 n'est pas traitée, elle n'est pas déplacée.

J'essaierai de corriger cela quand j'aurai le temps.

 

[Twisty]

Merci job ...

 

[job75]

Cette macro me paraît convenir :

Sub Classement()
Dim derlig&, n&, i As Variant
derlig = Application.Max(Application.CountA(Columns(1)), Application.CountA(Columns(4))) + 1
Application.ScreenUpdating = False
For n = 3 To derlig - 1
    If Cells(n, 4) <> "" Then
        i = Application.Match(Cells(n, 4), Columns(1), 0)
        If IsError(i) Then
            Cells(n, 4).Resize(, 3).Cut Cells(derlig, 4) 'couper-coller
            derlig = derlig + 1
        ElseIf i <> n Then
            Cells(n, 4).Resize(, 3).Cut
            Cells(i, 4).Insert xlDown
        End If
    End If
Next
'---supprime les lignes entièrement vides---
For n = derlig - 1 To 3 Step -1
    If Application.CountA(Rows(n)) = 0 Then Rows(n).Delete
Next
End Sub

 

[Twisty]

Merci job et bonne journée.
J'ai enfin mon petit prog grâce à vous tous

 

[job75]

Bonjour Twisty, le forum,

S'il y a des doublons en colonnes A et D (en bleu) il faut d'abord les supprimer.

Ici cela se fait grâce à la macro paramétrée Doublons :

Sub Classement()
Dim derlig&, n&, i As Variant
derlig = Application.Max(Application.CountA(Columns(1)), Application.CountA(Columns(4))) + 1
Application.ScreenUpdating = False
Doublons Range("A3:C" & derlig - 1), 3
Doublons Range("D3:F" & derlig - 1), 3
For n = 3 To derlig - 1
    If Cells(n, 4) <> "" Then
        i = Application.Match(Cells(n, 4), Columns(1), 0)
        If IsError(i) Then
            Cells(n, 4).Resize(, 3).Cut Cells(derlig, 4) 'couper-coller
            derlig = derlig + 1
        ElseIf i <> n Then
            Cells(n, 4).Resize(, 3).Cut
            Cells(i, 4).Insert xlDown
        End If
    End If
Next
'---supprime les lignes entièrement vides---
For n = derlig - 1 To 3 Step -1
    If Application.CountA(Rows(n)) = 0 Then Rows(n).Delete
Next
End Sub

Sub Doublons(plage As Range, col%)
Dim d As Object, i&, x$
Set d = CreateObject("Scripting.Dictionary")
For i = 1 To plage.Rows.Count
    x = plage(i, 1)
    If x <> "" Then
        If d.exists(x) Then
            plage(d(x), col) = plage(d(x), col) + plage(i, col)
        Else
            d(x) = i 'mémorise la ligne
        End If
    End If
Next
plage.RemoveDuplicates 1, Header:=xlNo 'supprime les lignes en doublon
End Sub

Les valeurs en 3èmes colonnes C et F sont additionnées.

A+