Autres Classement colonnes en VBA

T

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
job75
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...
Trier par date Trier par votes
T

Twisty

XLDnaute Nouveau
Twisty à dit:
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.
Cliquez pour agrandir...

Oneida à dit:
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?
Cliquez pour agrandir...
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
 
Vote positif 0 Vote négatif
ChTi160

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
Vote positif 0 Vote négatif
job75

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
Vote positif 0 Vote négatif
T

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
Vote positif 0 Vote négatif
job75

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
Vote positif 0 Vote négatif
job75

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
Vote positif 0 Vote négatif

Discussions similaires

J
  • Question
XL 2021 Classement avec ex aequo parfait
Réponses
3
Affichages
478
Jul1en
J
M
  • Question
XL 2019 Réaliser un classement automatique pour un tournoi enfants à Mario Kart
Réponses
2
Affichages
656
michel8032
M
S
  • Résolu(e)
Microsoft 365 [RESOLU] Excel : Calcul de prix en fonction d'un type
Réponses
4
Affichages
176
JHA
J
I
  • Résolu(e)
XL 2021 Somme cellule a droite du critère 1 ligne plusieurs colonnes
Réponses
5
Affichages
156
Idealnight
I
3
  • Question
XL 2013 Recherche a plusieurs critéres
Réponses
2
Affichages
439
Gégé-45550
Gégé-45550
C
  • Question
Microsoft 365 MFC colonnes + description +date du jour
Réponses
5
Affichages
251
fanfan38
fanfan38
C
  • Résolu(e)
Microsoft 365 Problème VBA lors de l'affichage de ligne masquée
2
Réponses
21
Affichages
618
Chris Linefield
C
G
  • Résolu(e)
XL 2021 départage æquo classement sportif
Réponses
11
Affichages
593
gigi71960
G
C
  • Question
XL 2021 Valeurs en fonction de l'âge (jours)
Réponses
4
Affichages
184
Dranreb
Dranreb
T
  • Résolu(e)
XL 2019 Problème tableau structuré et code vba
2
Réponses
28
Affichages
844
Cousinhub
Cousinhub

Membres actuellement en ligne

9 membres et 82 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
314 732
Messages
2 112 284
Membres
111 497
dernier inscrit
cerber08