Autres Classement colonnes en VBA

Twisty

XLDnaute Nouveau
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.
 

Pièces jointes

  • 1.xls
    27 KB · Affichages: 19
Solution
Ce n'est pas fini, en utilisant un tableau VBA la macro s'exécute en 0,15 seconde :
VB:
Sub Classement()
Dim derlig&, d As Object, n&, x$, tablo, lig&
derlig = Cells.SpecialCells(xlCellTypeLastCell).Row
Application.ScreenUpdating = False
Range("A3:C" & derlig).Sort [A3], xlAscending, Header:=xlNo 'tri
Range("D3:F" & derlig).Sort [D3], xlAscending, Header:=xlNo 'tri
Doublons Range("A3:C" & derlig), 3
Doublons Range("D3:F" & derlig), 3
'---liste des numéros de lignes---
Set d = CreateObject("Scripting.Dictionary")
For n = 3 To derlig
    x = CStr(Cells(n, 1))
    If x <> "" Then d(x) = n 'mémorise le numéro de ligne
Next n
'---remises en place dans le tableau D E F---
ReDim tablo(1 To derlig - 2, 1 To 3) 'tableau VBA vide (plus...

Twisty

XLDnaute Nouveau
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
 

ChTi160

XLDnaute Barbatruc
Bonjour le Fil
ce que j'ai mis dans un Module standard
VB:
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
 

Pièces jointes

  • Test Chti160.xls
    64.5 KB · Affichages: 6

job75

XLDnaute Barbatruc
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é :
VB:
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+
 

Pièces jointes

  • 1.xls
    49 KB · Affichages: 4

Twisty

XLDnaute Nouveau
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.
 

Pièces jointes

  • 1.xls
    27.5 KB · Affichages: 8

job75

XLDnaute Barbatruc
Cette macro me paraît convenir :
VB:
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
 

Pièces jointes

  • 1.xls
    50.5 KB · Affichages: 6

job75

XLDnaute Barbatruc
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 :
VB:
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+
 

Pièces jointes

  • 1.xls
    52.5 KB · Affichages: 14

Discussions similaires

Statistiques des forums

Discussions
313 322
Messages
2 097 141
Membres
106 851
dernier inscrit
Rv34