Microsoft 365 code vba : trier selon un ou plusieurs criteres

[mo_owen]

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

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

 

[danielco]

Bonjour,

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

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]

Bonjour,

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

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