Report d'une boucle tableau sur une boucle liste

Le 08/01/2025 à 21:13

Bonjour à tous,

Je bloque depuis hier sur ce probléme.

J'ai un tableau avec des champs qui se répètent à partir de la colonne 10. 7 champs/colonnes qui concerne la 1ere recolte jusqu'à la 5eme récolte soit 35 champs/colonnes en plus des 10 colonnes, donc un tableau de 45 colonnes.

Je cherche à faire une liste qui reprend 3 des 7 champs, donc avec 5 x 3 colonnes en plus des 5 premieres.

Avec ce code :

Private Sub parcl_change()
'donnees cultures de la parcelle, recolte en cours
    Dim i%, j%, k%, lig%, col%, tb1 As ListObject
    Set ws1 = Sheets("Cultures")
    Set tb1 = ws1.ListObjects("Culturs")
    Application.ScreenUpdating = False
    'effacement liste précédente
    Me.lstCults.Clear
    For i = 1 To tb1.ListRows.Count
        'si parcelle et non recoltés
        If tb1.DataBodyRange(i, 5).Value = Me.parcl.Value And tb1.DataBodyRange(i, 9).Value = "" Then
            Me.lstCults.AddItem
            Me.lstCults.List(Me.lstCults.ListCount - 1, 0) = tb1.DataBodyRange(i, 2).Value  'ref
            Me.lstCults.List(Me.lstCults.ListCount - 1, 1) = tb1.DataBodyRange(i, 3).Value  'culture
            Me.lstCults.List(Me.lstCults.ListCount - 1, 2) = tb1.DataBodyRange(i, 4).Value  'variete
            Me.lstCults.List(Me.lstCults.ListCount - 1, 3) = Format(tb1.DataBodyRange(i, 6).Value, "dd/mm/yyyy") 'date semis
            Me.lstCults.List(Me.lstCults.ListCount - 1, 4) = tb1.DataBodyRange(i, 7).Value  'semaine semis
            For j = 0 To 4
                 If tb1.DataBodyRange(i, (j * 7) + 10).Value <> "" Then '17 24 31 38 45
                 k = j * 3
                     Me.lstCults.List(Me.lstCults.ListCount - 1, (j * 3) + 5) = tb1.DataBodyRange(i, (j * 7) + 10).Value 'date récolte
                     Me.lstCults.List(Me.lstCults.ListCount - 1, (j * 3) + 6) = CSng(tb1.DataBodyRange(i, (j * 7) + 11).Value) 'semaine recolte
If i = 16 And j = 1 Then MsgBox DateDiff("d", tb1.DataBodyRange(i, 6).Value, tb1.DataBodyRange(i, (j * 7) + 10).Value): GoTo fin
                     Me.lstCults.List(Me.lstCults.ListCount - 1, (j * 3) + 7) = DateDiff("d", tb1.DataBodyRange(i, 6).Value, tb1.DataBodyRange(i, (j * 7) + 10).Value) 'duree jrs
                 End If
            Next j
        End If
    Next i
    'larg cols et 1ere ligne sélectionnee
fin:
    If Me.lstCults.ListCount <> 0 Then
            Me.lstCults.ColumnWidths = "30;50;50;50;30;50;30;30;50;30;30;50;30;30;50;30;30;50;30;30" 'largeur cols listbox
        Me.lstCults.Selected(0) = True 'remplissage champs UF avec notes devoirs selon matiére
    End If
    'commentaires
    For j = 0 To Me.lstCults.ListCount - 1
        For i = 1 To tb1.ListRows.Count
            If tb1.DataBodyRange(i, 2).Value = Me.lstCults.List(0, 0) And Me.lstCults.Selected(j) = True Then
                Me.obs.Value = tb1.DataBodyRange(i, 8).Value 'Obs
            End If
        Next i
    Next j
    'revenir à la page de l'index
     Me.MultiPage1.Value = cpt1
     Application.ScreenUpdating = True
End Sub

Voilà le résultat que j'obtiens en faisant un goto fin aprés le 1er enregistrement.

image

Il m'enregistre correctement les 3 champs de la 1ere récolte, mais à la 2eme récolte il me place la semaine en colonne 14, en récolte 4. Et aprés çà plus rien.

Pour reproduire le probléme, il faut doublecliquer sur la parcelle D2, qui comporte un enregistrement avec les 5 récoltes.

Merci de votre aide.

12forum.zip (457.58 Ko)
Le 08/01/2025 à 21:41

Bonsoir à tous 🙂

guypio, pour alimenter ta listbox de champs discontinus, tu peux utiliser Application.Index

Voir différents exemples sur le site de Jacques Boisgontier

klin89

Le 08/01/2025 à 22:16

Bsoir Klin89,

Ok j'ai trouvé ici.

je vais regarder çà, merci.

Le 09/01/2025 à 09:30

Bonjour,

Cà fonctionne pour les colonnes, mais je n'arrive pas à filtrer les lignes sur la parcelle.

'PARCELLES DU JARDIN
'Liste des cultures sur une parcelle
Private Sub UserForm_Initialize()
    'listes déroulantes
    Me.parcl.List = Range("Parcels[Parcelle]").Value 'unité3
    'trouve le num parcelle en culture
    lig = ActiveCell.Row
    col = ActiveCell.Column
    parcl = Mid(Cells(lig, col).Value, 10, 2) 'Ref parcelle
'  Set f = Sheets("bd")
'  TblBD = f.Range("A2:F" & f.[A65000].End(xlUp).Row).Value
'  Me.lstCults.List = TblBD
End Sub

Private Sub parcl_change()
  Dim ColVisu(), LargeurCol(), Rng
  Set f = Sheets("Cultures")                          ' Adapter
  Set Rng = f.Range("A2:AR" & f.[A6500].End(xlUp).Row) ' Adapter
  ColVisu = Array(2, 3, 4, 6, 7, 10, 11, 12, 17, 18, 19, 24, 25, 26, 31, 32, 33, 38, 39, 40)
  LargeurCol = Array(30, 50, 50, 50, 30, 50, 30, 30, 50, 30, 30, 50, 30, 30, 50, 30, 30, 50, 30, 30) ' Adapter
  Me.lstCults.ColumnCount = UBound(ColVisu) + 1
  Me.lstCults.ColumnWidths = Join(LargeurCol, ";")
  TblBD = Application.Index(Rng, Evaluate("Row(1:" & Rng.Rows.Count & ")"), ColVisu)
  'critere
 For i = 1 To UBound(TblBD)
 If TblBD(i, 5) = Me.parcl.Value Then

  'format date
    Me.lstCults.List(15, 3) = Format(Me.lstCults.List(15, 3), "dd/mm/yy") 'date semis
    For j = 5 To 17 Step 3
      Me.lstCults.List(15, j) = Format(Me.lstCults.List(15, j), "dd/mm/yy") 'date semis
    Next j
    'calcul nbre jours
    For j = 7 To 17 Step 3
      Me.lstCults.List(15, j) = CDate(Me.lstCults.List(15, j - 2)) - CDate(Me.lstCults.List(15, 3)) 'ColVisu(10) - ColVisu(6)
    Next j
' EnteteListBox
End Sub
image
12forum.zip (459.50 Ko)
Le 09/01/2025 à 14:34

J'essaie de comprendre les variables tableau avec le 1er exemple du blog de J Boisgontier.

J'ai reproduit son exemple avec 2 colonnes a et b, çà fonctionne.

Mais dés que je décale sur les colonnes d et e çà bug.

Private Sub UserForm_Initialize()
Dim f As Worksheet, bd(), n%, i%, j%, k%
  Set f = Sheets("Cultures")
  bd = f.Range("d2:e" & f.[A65000].End(xlUp).Row).Value
  Me.ListBox1.ColumnCount = 2
  Me.ListBox1.ColumnWidths = "45;50"
  n = 0
  For i = 1 To UBound(bd)
    If bd(i, 2) = "D2" Then n = n + 1 'Me.parcl.Value
  Next i
  j = 0
  Dim Tbl:  ReDim Tbl(1 To n, 1 To 2)
  For i = 1 To UBound(bd)
'MsgBox bd(i, 2): GoTo fin
     If bd(i, 2) = "D2" Then j = j + 1: For k = 1 To 2: Tbl(j, k) = bd(i, k + 1): Next k
  Next i
  Me.ListBox1.List = Tbl
fin:
End Sub
image

Savez-vous pourquoi ?

Merci

17forum.zip (467.52 Ko)
Le 09/01/2025 à 16:51

Bonjour,

Dans cette ligne

If bd(i, 2) = "D2" Then j = j + 1: For k = 1 To 2: Tbl(j, k) = bd(i, k+1): Next k

Que je réécris, pour y voir plus clair et pointer le problème :

     If bd(i, 2) = "D2" Then
        j = j + 1
        For k = 1 To 2
          Tbl(j, k) = bd(i, k+1) ' problème ici
        Next k
     End If

À l'instruction Tbl(j, k) = bd(i, k+1) vous levez obligatoirement une erreur : votre tableau bd n'a que 2 colonnes ! (D:E). Donc avec k allant de 1 à 2, puis en faisant k+1 vous atteignez 3 : l'indice n'est pas accepté puisque hors du tableau.

Je ne connais pas grand chose de votre projet, mais à mon avis la correction voulue est celle-ci (enlever le +1) :

If bd(i, 2) = "D2" Then j = j + 1: For k = 1 To 2: Tbl(j, k) = bd(i, k): Next k
Le 09/01/2025 à 17:11

Bonjour Saboh12617,

J'ai reproduis le même code pour juste 2 colonnes différentes, et çà bug pas dans l'autre exemple, donc à quoi sert ce k+1, et pourquoi çà bug pas en ajoutant une colonne à 2 à partir des colonnes a et b ?

Merci

Le 09/01/2025 à 17:30

Bonjour,

Sans vouloir etre méchant ou hautain j'ai l'impression que vous ne saisissez pas très bien le code que vous avez écrit/repris.

Si tel est le cas, dites-le, car j'essaierai de vous donner des réponses plus complètes.

En l'occurrence, c'est ici que tout se fait :

bd = f.Range("d2:e" & f.[A65000].End(xlUp).Row).Value

D:E sont deux colonnes adjacentes, donc bd contient un tableau à 2 colonnes.

Si vous mettez par exemple les colonnes D:F,

bd = f.Range("D2:F" & f.[A65000].End(xlUp).Row).Value

Alors bd devient un tableau à trois colonnes : D,E,F. Donc ça ne "bug pas". C'est surement pour ça que vous n'aviez pas d'erreur.

Mais bon. moi je ne sais pas comment fonctionne votre macro, votre fichier… c'est très lourd. J'ai juste vu une erreur facile à résoudre et je vous ai donné la piste de résolution. Après si vous voulez que je/on vous revoie toute la macro, il faut le dire. Et surtout bien préciser l'objectif final car normalement vous n'allez pas modifier ce code tous les jours, les colonnes choisies devraient rester constantes.

Le 09/01/2025 à 17:46

Effectivement, il y avait les colonnes a à c dans le 1er exemple, d'ou le rajout possible d'une colonne. Désolé

Même si c'est d'aucune utilité pour moi de rajouter une colonne, je continue d'essayer de trouver le code pour filtrer la BD et transférer le résultat d'un tableau à l'autre. Y'a beaucoup d'exemples sur le site de J Boisgontier, mais trés peu d'explications. Merci

image
Le 09/01/2025 à 22:53

Bonsoir à tous,

Salut saboh12617,

Personnellement, je ne sais pas vraiment bien gérer les interactions entre tous les contrôles d’un formulaire.

D’après ce que j’ai compris :

  • Vous sélectionnez une parcelle en cliquant dans la feuille "Parcelles". Cela applique un filtre sur la 5ᵉ colonne de la feuille "Cultures", faisant apparaître le nom de la parcelle dans la combobox nommée "parcl".
  • Ensuite, vous souhaitez afficher les lignes filtrées dans la listbox nommée "lstCults", en ne sélectionnant que certaines colonnes de la feuille "Cultures".

Dans l’événement Change de cette combobox, j’ai ajouté ce code qui accomplit cette tâche.

Private Sub parcl_change()
    Dim LargeurCol, x, y, i As Long
    With Sheets("Cultures").Cells(1).CurrentRegion
        x = Filter(.Parent.Evaluate("transpose(if(" & .Columns(5).Address & "=""" & Me.parcl.Value & _
                                    """,row(1:" & .Rows.Count & "),char(2)))"), Chr(2), 0)
        If UBound(x) > -1 Then
            y = Application.Index(.Value, Application.Transpose(x), Array(2, 3, 4, 6, 7, 10, 11, 12, 17, 18, 19, 24, 25, 26, 31, 32, 33, 38, 39, 40))
            If UBound(x) = 0 Then
                Me.lstCults.Column = y
            Else
                Me.lstCults.List = y
            End If
        End If
        LargeurCol = Array(30, 50, 50, 50, 30, 50, 30, 30, 50, 30, 30, 50, 30, 30, 50, 30, 30, 50, 30, 30)    ' Adapter
        Me.lstCults.ColumnCount = 20
        Me.lstCults.ColumnWidths = Join(LargeurCol, ";")
    End With
End Sub

Je laisse les « spécialistes des formulaires » peaufiner et s’occuper de la suite.

klin89

Le 10/01/2025 à 01:58

Excellent travail Klin89,

C'est bien çà ma demande. Et çà filtre aussi les autres parcelles en liste déroulante, à part cette semaine en isoweek qui réapparait souvent toute seule.

image

Mais

Par contre le code du filtre m'est pas familler, et si je souhaite filtrer encore avec les récoltés et l'option X, çà bug.

image image

J'ai aussi quelques questions :

A quoi servent les char(2) et chr(2) ?

Je comprends pas cette ligne

            If UBound(x) = 0 Then 's'il y a une ligne..
                Me.lstCults.Column = y

Merci

Le 11/01/2025 à 10:10

Bonjour à tous,

J'essaie de changer le filtre sur un autre critère, mais çà ne passe pas.

        x = Filter(.Parent.Evaluate("transpose(if(" & .Columns(9).Address & "=""" & "X" & """),row(1:" & .Rows.Count & "),char(2)))"), Chr(2), 0)

Quelqu'un pourrait-il me corriger ?

Pour reproduire le bug, doublecliquez sur la parcelle D2

Merci

10forum.zip (469.97 Ko)
Le 11/01/2025 à 12:09

Re guipio

Via la fonction Filter, x renvoie un tableau de valeurs correspondant au numéro de lignes répondant aux critères énoncés, à savoir la valeur de la ComboBox "parcl" et la valeur de la CheckBox "recolt", ce qui permet de filtrer la ListBox "lstCults" comme tu le souhaites.

Essaie ceci :

Private Sub parcl_change()
    Dim LargeurCol, x, y, i As Long
    With Sheets("Cultures").Cells(1).CurrentRegion
        If Me.recolt.Value = False Then
            x = Filter(.Parent.Evaluate("transpose(if((" & .Columns(5).Address & "=""" & Me.parcl.Value & _
                                        """)*( " & .Columns(9).Address & "=""""),row(1:" & .Rows.Count & ")))"), False, 0)
        Else
            x = Filter(.Parent.Evaluate("transpose(if((" & .Columns(5).Address & "=""" & Me.parcl.Value & _
                                        """)*( " & .Columns(9).Address & "=""X""),row(1:" & .Rows.Count & ")))"), False, 0)
        End If
        If UBound(x) > -1 Then
            y = Application.Index(.Value, Application.Transpose(x), Array(2, 3, 4, 6, 7, 10, 11, 12, 17, 18, 19, 24, 25, 26, 31, 32, 33, 38, 39, 40))
            If UBound(x) = 0 Then
                Me.lstCults.Column = y
            Else
                Me.lstCults.List = y
            End If
        End If
        LargeurCol = Array(30, 50, 50, 50, 30, 50, 30, 30, 50, 30, 30, 50, 30, 30, 50, 30, 30, 50, 30, 30)    ' Adapter
        Me.lstCults.ColumnCount = 20
        Me.lstCults.ColumnWidths = Join(LargeurCol, ";")
    End With
End Sub

Encore une fois, je ne maitrise pas assez bien les événements des différents contrôles composant un UserForm pour pouvoir continuer à t'aider.

Là, je me suis seulement concentré sur ton problème concernant le filtre de la ListBox, le reste est à revoir.

klin89

Le 11/01/2025 à 16:14

Re,

Non, il ne faut pas l'un ou l'autre filtre mais les 2.

Mais j'y suis arrivé. Mon probléme de départ était q'une listbox ne peut pas faire plus de 10 colonnes, et je me suis rabattu sur les tableaux pour y stocker les données. ouf !

18forum.zip (469.78 Ko)

J'ai plus qu'un souci, c'est donner une dimension de nombre de lignes variable au tableau.

A+

Le 11/01/2025 à 20:41

re,

votre dernier fichier est lequel et c'est quoi le problème pour le moment ?

Le 11/01/2025 à 20:44

re guypio

Purée, faut te suivre toi

D'après ce que je comprends, tu veux dimensionner la 1ère dimension de la variable tableau tb en amont.

Vois avec Evaluate :

Set ws1 = Sheets("Cultures")
Set rng = ws1.Range("e1:e42") 'colonne 5
Set rng1 = ws1.Range("i1:i42") 'colonne 9
' ici je compte le nombre de lignes de la parcelle désignée par les 2 critères
' appliqués sur la colonne 5 et 9
nLig = ws1.Evaluate("COUNT(IF((" & Rng.Address & "=""" & Me.parcl.Value & """)*(" & Rng1.Address & "=""""),1))")
ReDim tb(1 To nLig, 1 To 20)

Ou celle-ci :

nLig = ws1.Evaluate("SUMPRODUCT((" & Rng.Address & "=""" & Me.parcl.Value & """)*" & _
                                 "(" & Rng1.Address & "=""""))")

A adapter à ton tableau structuré.

Edit : salut BsAlv

klin89

Le 11/01/2025 à 21:03

Bonjour Bsalv,

Le dernier fichier est celui au-dessus.

Klin89,

Oui je me suis embété avant de reprendre les add.items et de voir qu'ils passaient toujours pas à 11...

Non, j'évalue le nombre de lignes du tableau, donc celles concernées par la liste.

Mais je vais faire la boucle avant,

Merci.

Le 11/01/2025 à 21:19

re,

n'est-ce pas ubound(x)+1

Le 11/01/2025 à 21:27

Bsalv,

Non çà a pas l'air de marcher à la place de x = x + 1

çà fonctionne que si je mets tb(10,20)

si je mets tb(20) pour essayer de dimensionner le nombre de lignes, çà passe pas, je sais pas comment faire.

Le 12/01/2025 à 21:49

Re

C'est ça que tu veux dans l'évènement change de la ComboBox , vois les ajustements :

Private Sub parcl_change()
'donnees cultures de la parcelle non recoltés
Dim tb(), nLig As Long

nLig = ws1.Evaluate("SUMPRODUCT((" & tb1.ListColumns(5).DataBodyRange.Address & "=""" & Me.parcl.Value & """)*" & _
                    "(" & tb1.ListColumns(9).DataBodyRange.Address & "=""""))")

If nLig > 0 Then
    ReDim tb(1 To nLig, 1 To 20)
    For i = 1 To tb1.ListRows.Count
        If tb1.DataBodyRange(i, 5).Value = Me.parcl.Value And tb1.DataBodyRange(i, 9).Value = "" Then
            x = x + 1
            tb(x, 1) = tb1.DataBodyRange(i, 2).Value  'ref
            tb(x, 2) = tb1.DataBodyRange(i, 3).Value  'culture
            tb(x, 3) = tb1.DataBodyRange(i, 4).Value  'variete
            tb(x, 4) = Format(tb1.DataBodyRange(i, 6).Value, "dd/mm/yyyy")    'date semis
            tb(x, 5) = CSng(tb1.DataBodyRange(i, 7).Value)  'semaine semis
            For j = 0 To 4
                If tb1.DataBodyRange(i, (j * 7) + 10).Value <> "" Then
                    tb(x, (j * 3) + 5) = Format(tb1.DataBodyRange(i, (j * 7) + 10).Value, "dd/mm/yyyy")    'date récolte
                    tb(x, (j * 3) + 6) = tb1.DataBodyRange(i, (j * 7) + 11).Value    'semaine recolte
                    tb(x, (j * 3) + 7) = DateDiff("d", tb1.DataBodyRange(i, 6).Value, tb1.DataBodyRange(i, (j * 7) + 10).Value)    'duree
                End If
            Next j
        End If
    Next i
    Me.lstCults.List = tb
End If

Sinon, passe par un « Redim Preserve »

klin89

Rechercher des sujets similaires à "report boucle tableau liste"