Microsoft 365 code vba : trier selon un ou plusieurs criteres

mo_owen

XLDnaute Nouveau
Bonjour a tous Désolé de vous déranger pour une dernière fois, vraiment désolé mais j'ai besoin de votre aide, je peine
Lors de ma précédente demande, j'ai oublié le critère le plus important d'où je reviens encore une fois de plus. Je veux un code VBA ou Solution BI

ci joint deux captures d'écran qui résument le résultat souhaité.

Description de ma demande :
je souhaiterais Avoir un fichier où, j'aurai pour un même numéro de dossier, le dossier le plus récent et le plus ancien en tenant compte du critère envoyeur, récepteur.
Pour le dossier le plus ancien, l'envoyeur doit toujours être A .
Pour le dossier le plus récent, le récepteur doit toujours être A.
De plus le récepteur pour le dossier le plus ancien doit être l'envoyeur du dossier le plus récent. En gros si
A envoi a B, B renvoi a A. oubien si A envoi a Z, Z renvoi a A. etc..............

Ci joint les images et le fichier Excel pour la pratique.

VOICI UN EXEMPLE MAIS IL Y A UN FICHIER EXCEL EN PIECE JOINTE.

fichier test

1663916712720.png




SUR CE PREMIER RESULTAT ATTENDU JE VEUX FAIRE UNE DIFFERENCE DE DATE EN JOUR
 

Pièces jointes

  • test3.xlsx
    10.6 KB · Affichages: 6
Dernière édition:

danielco

XLDnaute Accro
Bonjour,

Il y a sans doute plus simple et il y a des différences. Vérifie :

VB:
Sub test()
  Dim Tabl1, Ctr As Long, Tabl2(), I As Long, Dico As Object, J As Long, K As Long
  Dim Ligne As Long
  Set Dico = CreateObject("Scripting.Dictionary")
  With Sheets("RESULTAT ATTENDU")
    .Range("A2", .Cells(.Rows.Count, 5).End(xlUp)).Value = ""
  End With
  With Sheets("TEST")
    Tabl1 = .Range("A2", .Cells(.Rows.Count, 5).End(xlUp))
    'Excel 365 uniquement
    Ctr = Application.CountA(Application.Unique(.Range("A2", _
      .Cells(.Rows.Count, 1).End(xlUp))))
    ReDim Tabl2(5, Ctr)
    Ctr = -1
    For I = 1 To UBound(Tabl1, 1)
      If Not Dico.exists(Tabl1(I, 1)) Then
        Dico.Add Tabl1(I, 1), Tabl1(I, 1)
        Ctr = Ctr + 1
        ReDim Preserve Tabl2(5, Ctr)
        For J = 0 To 4
          Tabl2(J, Ctr) = Tabl1(I, J + 1)
        Next J
        Tabl2(5, Ctr) = "min"
        Ctr = Ctr + 1
        ReDim Preserve Tabl2(5, Ctr)
        For J = 0 To 4
          Tabl2(J, Ctr) = Tabl1(I, J + 1)
        Next J
        Tabl2(5, Ctr) = "max"
      Else
        For K = 0 To UBound(Tabl2, 2)
          If Tabl2(0, K) = Tabl1(I, 1) And Tabl2(5, K) = "min" Then
            If Tabl2(1, K) < Tabl1(I, 2) Then
              For J = 0 To 4
                Tabl2(J, K) = Tabl1(I, J + 1)
              Next J
            End If
          ElseIf Tabl2(0, K) = Tabl1(I, 1) And Tabl2(5, K) = "min" Then
            If Tabl2(1, K) > Tabl1(I, 2) Then
              For J = 0 To 4
                Tabl2(J, K) = Tabl1(I, J + 1)
              Next J
            End If
          End If
        Next K
      End If
    Next I
  End With
  With Sheets("RESULTAT ATTENDU")
    For I = 0 To UBound(Tabl2, 2) - 1
      If Tabl2(0, I) = Tabl2(0, I + 1) And Tabl2(1, I) <> Tabl2(1, I + 1) Then
        Ligne = Ligne + 2
        For J = 0 To 4
          .Cells(Ligne + 1, 1).Offset(, J) = Tabl2(J, I + 1)
          .Cells(Ligne, 1).Offset(, J) = Tabl2(J, I)
        Next
      End If
    Next I
  End With
End Sub

Daniel
 

mo_owen

XLDnaute Nouveau
Bonjour,

Il y a sans doute plus simple et il y a des différences. Vérifie :

VB:
Sub test()
  Dim Tabl1, Ctr As Long, Tabl2(), I As Long, Dico As Object, J As Long, K As Long
  Dim Ligne As Long
  Set Dico = CreateObject("Scripting.Dictionary")
  With Sheets("RESULTAT ATTENDU")
    .Range("A2", .Cells(.Rows.Count, 5).End(xlUp)).Value = ""
  End With
  With Sheets("TEST")
    Tabl1 = .Range("A2", .Cells(.Rows.Count, 5).End(xlUp))
    'Excel 365 uniquement
    Ctr = Application.CountA(Application.Unique(.Range("A2", _
      .Cells(.Rows.Count, 1).End(xlUp))))
    ReDim Tabl2(5, Ctr)
    Ctr = -1
    For I = 1 To UBound(Tabl1, 1)
      If Not Dico.exists(Tabl1(I, 1)) Then
        Dico.Add Tabl1(I, 1), Tabl1(I, 1)
        Ctr = Ctr + 1
        ReDim Preserve Tabl2(5, Ctr)
        For J = 0 To 4
          Tabl2(J, Ctr) = Tabl1(I, J + 1)
        Next J
        Tabl2(5, Ctr) = "min"
        Ctr = Ctr + 1
        ReDim Preserve Tabl2(5, Ctr)
        For J = 0 To 4
          Tabl2(J, Ctr) = Tabl1(I, J + 1)
        Next J
        Tabl2(5, Ctr) = "max"
      Else
        For K = 0 To UBound(Tabl2, 2)
          If Tabl2(0, K) = Tabl1(I, 1) And Tabl2(5, K) = "min" Then
            If Tabl2(1, K) < Tabl1(I, 2) Then
              For J = 0 To 4
                Tabl2(J, K) = Tabl1(I, J + 1)
              Next J
            End If
          ElseIf Tabl2(0, K) = Tabl1(I, 1) And Tabl2(5, K) = "min" Then
            If Tabl2(1, K) > Tabl1(I, 2) Then
              For J = 0 To 4
                Tabl2(J, K) = Tabl1(I, J + 1)
              Next J
            End If
          End If
        Next K
      End If
    Next I
  End With
  With Sheets("RESULTAT ATTENDU")
    For I = 0 To UBound(Tabl2, 2) - 1
      If Tabl2(0, I) = Tabl2(0, I + 1) And Tabl2(1, I) <> Tabl2(1, I + 1) Then
        Ligne = Ligne + 2
        For J = 0 To 4
          .Cells(Ligne + 1, 1).Offset(, J) = Tabl2(J, I + 1)
          .Cells(Ligne, 1).Offset(, J) = Tabl2(J, I)
        Next
      End If
    Next I
  End With
End Sub

Daniel
Bonjour Merci pour ta réponse, je vérifie et je reviens vite
 

Discussions similaires

  • Résolu(e)
Microsoft 365 Excel VBA
Réponses
50
Affichages
2 K
Réponses
13
Affichages
474

Statistiques des forums

Discussions
311 730
Messages
2 081 989
Membres
101 856
dernier inscrit
Marina40