XL 2010 Trouver un ordre en fonction d'une donnée

[Chubby]

Bonjour,

Pas très clair mon titre, j'en conviens.
Je vous explique.
J'ai un tableau qui reprend les jours de vendanges au fil des années. Je voudrais trouver le J1, J2 de chaque millésime autrement que manuellement. Je vous joins un bout de tableau pour être plus explicite.
La seconde question serait de trouver le J1, J2 après avoir filtrer les appellations.
Vous voyez un point de départ?
Merci à vous pour vos idées

 

[job75]

Bonjour Chubby,

Voyez le fichier joint et ces 2 macros :

Dim J$, an%, lig& 'mémorise les variables

Sub Jour()
'se lance par Ctrl+J
Dim i&
If J = "" Then J = "J1" Else J = IIf(J = "J1", "J2", "J1")
If J = "J2" Then an = an - 1
With [A1].CurrentRegion 'adapter éventuellement
  .Cells(2, 4).Resize(Rows.Count - .Row).Interior.ColorIndex = xlNone 'RAZ couleur
  For i = IIf(lig, lig + 1, 2) To .Rows.Count
    If .Cells(i, 4) = J And Year(.Cells(i, 3)) > an And Not .Rows(i).Hidden Then
      .Cells(i, 4).Select
      ActiveCell.Interior.ColorIndex = 6 'jaune
      an = Year(.Cells(i, 3))
      lig = i
      Exit Sub
    End If
  Next
  an = an + 1
End With
End Sub

Sub RAZ()
'se lance par Ctrl+R
If ActiveSheet.FilterMode Then ActiveSheet.ShowAllData 'si la feuille est filtrée
With [A1].CurrentRegion 'adapter éventuellement
  .Cells(2, 4).Resize(Rows.Count - .Row).Interior.ColorIndex = xlNone 'RAZ couleur
  .Sort .Columns(3), xlAscending, Header:=xlYes 'tri sur les dates
End With
J = "": an = 0: lig = 0
End Sub

Edit : si ce n'est pas ce que vous attendez précisez ce que vous voulez dire par "trouver le J1, J2 de chaque millésime" ou par "avoir automatiquement le N° Jours".

A+

 

[Chubby]

Bonjour Job75, bonjour les zôtres,
Je te remercie de ton aide. En revanche je n'arrive pas vraiment à comprendre ton travail... et pour cause je me suis mal exprimé.
Trouver n'est effectivement pas le bon terme. il s'agit en fait d'attribuer un ordre au sein d'une année (demande 1), selon les appellations filtrées (demande 2).
Donc attribuer J1, J2, J3 ... etc...en fonction de la date.... en fonction appellation.
Je ne sais pas si je suis plus clair. Dis moi
Merci encore

 

[Dranreb]

Bonjour.
Je dirais :
En D2 :

1

En D3, à propager sur 21 lignes :

=SI(ET($J3=DECALER($J3;-1;0);ANNEE($C3)=ANNEE(DECALER($C3;-1;0)));DECALER(D3;-1;0)+($C3>DECALER($C3;-1;0));1)

Format de nombre personnalisé :

"J"Standard

Edit: Important: classez par appellations puis par dates.

 

[Chubby]

Bonsoir Danreb,

Je te remercie pour ton travail. J'ai essayer de suivre tes instruction, assez naïvement j'avoue, et je me retrouve avec des J1 de partout sauf en D3 qui lui est J2.
J'essaie de regarder ça un peu mieux pour essayzer de trouver ce qui cloche dans ce que je fais benoitement.
Merci à toi

 

[Dranreb]

Les appellations ne sont peut être pas toutes ensembles.
Il faut classer par appellations puis par dates.

 

[job75]

Bonsoir Chubby, Bernard,

Ce n'était quand même pas difficile de dire qu'il fallait remplir la colonne D (N° Jours).

Alors voyez ce fichier (2) et la macro du bouton :

Private Sub CommandButton1_Click()
Dim t, d As Object, i&, x$
Application.ScreenUpdating = False
If FilterMode Then ShowAllData 'si la feuille est filtrée
With [A1].CurrentRegion 'adapter éventuellement
  .Sort .Columns(3), xlAscending, Header:=xlYes 'tri sur les dates
  t = .Resize(, 10) 'matrice, plus rapide
  Set d = CreateObject("Scripting.Dictionary")
  d.Comparemode = vbTextCompare 'la casse est ignorée
  For i = 2 To UBound(t)
    x = Year(t(i, 3)) & t(i, 10) 'millésime + appellation
    If d.exists(x) Then
      d(x) = "J" & Mid(d(x), 2) + 1
    Else
      d(x) = "J1"
    End If
    t(i, 4) = d(x)
  Next
  .Columns(4) = Application.Index(t, , 4) 'restitution
End With
End Sub

Le filtrage des appellations ne pose aucun problème puisque les séries J1 J2 J3... sont affectées à chaque appellation.

A+

 

[klin89]

Bonsoir à tous,

Pour répondre à la 1ère question, j'ai fait le choix d'un dictionnaire parent et d'un dictionnaire enfant
Les dates doivent être triées dans l'ordre chronologique
Pour la 2ème question, je n'ai rien compris

Option Explicit
Sub test()
Dim i As Long, dico As Object
    Set dico = CreateObject("Scripting.Dictionary")
    dico.Comparemode = 1
    Application.ScreenUpdating = False
    With Sheets("feuil1").[a1].CurrentRegion
        With .Columns(4).Offset(1)
            .ClearContents
            .NumberFormat = "General"
        End With
        For i = 2 To .Rows.Count
            If Not dico.exists(Year(.Cells(i, 2).Value)) Then
                Set dico(Year(.Cells(i, 2).Value)) = CreateObject("Scripting.Dictionary")
            End If
            If Not dico(Year(.Cells(i, 2).Value)).exists(.Cells(i, 2).Value) Then
                dico(Year(.Cells(i, 2).Value))(.Cells(i, 2).Value) = dico(Year(.Cells(i, 2).Value)).Count + 1
            End If
        Next
        For i = 2 To .Rows.Count
            .Cells(i, 4) = "J" & dico(Year(.Cells(i, 2).Value))(.Cells(i, 2).Value)
        Next
    End With
    Set dico = Nothing
    Application.ScreenUpdating = True
End Sub

klin89

 

[job75]

Bonjour Chubby, Bernard, klin89, le forum,

2 remarques sur votre fichier d'origine Chubby.

1) La colonne A doit être mise au format Texte.

Car si vous revalidez ses cellules vous aurez des soucis !

2) La colonne B peut être supprimée, il faut juste adapter la macro.

Fichier (2 bis).

Bonne journée.

 

[job75]

Re,

Voici une autre solution :

- la série des N° Jours est créée pour chaque millésime

- sur les lignes visibles uniquement

- la formule volatile en M1 crée l'évènement Calculate quand on filtre la feuille.

Le code utilise la macro de tri Quick sort bien connue :

Private Sub Worksheet_Calculate()
Dim t, i&, n&, a(), b(), d As Object, m%
With [A1].CurrentRegion 'adapter éventuellement
  t = .Resize(, 4) 'matrice, plus rapide
  For i = 2 To UBound(t)
    If Rows(i).Hidden Then
      t(i, 4) = "" 'RAZ
    Else
      ReDim Preserve a(n): ReDim Preserve b(n) 'base 0
      a(n) = t(i, 3) + i / "1E9" 'différenciation des jours pour le tri
      b(n) = i 'repérage de la ligne
      n = n + 1
    End If
  Next
  If n = 0 Then Exit Sub
  tri a, b, 0, UBound(a)
  Set d = CreateObject("Scripting.Dictionary")
  For i = 0 To UBound(a)
    If b(i) Then
      m = Year(Round(a(i))) 'millésime
      If d.exists(m) Then
        d(m) = "J" & Mid(d(m), 2) + Sgn(Round(a(i) - a(i - 1)))
      Else
        d(m) = "J1"
      End If
      t(b(i), 4) = d(m)
    End If
  Next
  '---restitution---
  Application.ScreenUpdating = False
  Application.EnableEvents = False
  For i = 2 To UBound(t)
    .Cells(i, 4) = t(i, 4)
  Next
  Application.EnableEvents = True
  Application.ScreenUpdating = True
End With
End Sub

Sub tri(a, b, gauc, droi)   ' Quick sort
Dim ref, g, d, temp
ref = a((gauc + droi) \ 2)
g = gauc: d = droi
Do
    Do While a(g) < ref: g = g + 1: Loop
    Do While ref < a(d): d = d - 1: Loop
    If g <= d Then
      temp = a(g): a(g) = a(d): a(d) = temp
      temp = b(g): b(g) = b(d): b(d) = temp
      g = g + 1: d = d - 1
    End If
Loop While g <= d
If g < droi Then Call tri(a, b, g, droi)
If gauc < d Then Call tri(a, b, gauc, d)
End Sub

Fichier (3) et (3 bis).

Les cellules étant traitées une par une c'est nettement moins rapide que les solutions (2).

A+

 

[job75]

Re,

Cette solution est une variante des fichiers (2) et (2 bis) :

Private Sub CommandButton1_Click()
Dim t, d As Object, i&, x$, jourprec&, y$
Application.ScreenUpdating = False
If FilterMode Then ShowAllData 'si la feuille est filtrée
With [A1].CurrentRegion 'adapter éventuellement
  .Sort .Columns(3), xlAscending, Header:=xlYes 'tri sur les dates
  t = .Resize(, 10) 'matrice, plus rapide
  Set d = CreateObject("Scripting.Dictionary")
  d.Comparemode = vbTextCompare 'la casse est ignorée
  For i = 2 To UBound(t)
    x = Year(t(i, 3)) & t(i, 10) 'millésime + appellation
    If d.exists(x) Then
      jourprec = CDate(Mid(d(x), InStr(d(x), "#") + 1))
      y = "J" & Val(Mid(d(x), 2)) - (t(i, 3) > jourprec)
      d(x) = y & "#" & t(i, 3)
      t(i, 4) = y
    Else
      d(x) = "J1" & "#" & t(i, 3)
      t(i, 4) = "J1"
    End If
  Next
  .Columns(4) = Application.Index(t, , 4) 'restitution
End With
End Sub

Avec les fichiers (2) et (2 bis) les N° Jours sont incrémentés même s'il s'agit du même jour.

Avec ces fichiers (4) et (4 bis) les N° ne sont pas incrémentés s'il s'agit du même jour.

A+

 

[klin89]

Re,

Pour répondre à la 2ème question :
J'ai gardé le tableau avec sa structure initiale (11 colonnes)
Je travaille directement dans le tableur et restitue par cellule contrairement à job75
C'est sûrement moins rapide et peut-être plus indigeste pour ceux qui maitrisent difficilement les dictionnaires

Option Explicit
Sub test()
Dim i As Long, dico As Object
    Set dico = CreateObject("Scripting.Dictionary")
    dico.Comparemode = 1
    Application.ScreenUpdating = False
    With Sheets("feuil1").[a1].CurrentRegion
        With .Columns(4).Offset(1)
            .ClearContents
            .NumberFormat = "General"
        End With
        For i = 2 To .Rows.Count
            If Not dico.exists(Year(.Cells(i, 2).Value)) Then
                Set dico(Year(.Cells(i, 2).Value)) = CreateObject("Scripting.Dictionary")
                dico(Year(.Cells(i, 2).Value)).Comparemode = 1
            End If
            If Not dico(Year(.Cells(i, 2).Value)).exists(.Cells(i, 10).Value) Then
                Set dico(Year(.Cells(i, 2).Value))(.Cells(i, 10).Value) = CreateObject("Scripting.Dictionary")
            End If
            If Not dico(Year(.Cells(i, 2).Value))(Cells(i, 10).Value).exists(.Cells(i, 2).Value) Then
                dico(Year(.Cells(i, 2).Value))(.Cells(i, 10).Value)(.Cells(i, 2).Value) = dico(Year(.Cells(i, 2).Value))(.Cells(i, 10).Value).Count + 1
            End If
        Next
        For i = 2 To .Rows.Count
            .Cells(i, 4) = "J" & dico(Year(.Cells(i, 2).Value))(.Cells(i, 10).Value)(.Cells(i, 2).Value)
        Next
    End With
    Set dico = Nothing
    Application.ScreenUpdating = True
End Sub

Bien sûr, les dates doivent être triées par ordre chronologique préalablement.

klin89

 

[Chubby]

Bonsoir Job75, Danreb, Bernard, klin89 et le forum,

Désolé pour mon retour bien tardif. Je vous remercie pour votre aide à tous. Mea culpa pour mon expression pas toujours très claire mais je vais pouvoir regarder ça plus tranquillement.
Merci encore.