Microsoft 365 Combobox ajouter si n'existe pas dans Liste

cathodique à dit:

Bonjour,

Sur mon excel 2010, ton fichier fonctionne. Je n'ai pas rencontré de plantage.

Bon dimanche.

Cliquez pour agrandir...

eric72 à dit:

Bonjour,

Merci pour ta réponse, quand tu dis qu'il fonctionne, cela veut dire que si tu inscris un fournisseur qui n'est pas dans la liste, il s'ajoute bien à la liste des fournisseurs? Bizarre, sur 365 ça plante...

Cliquez pour agrandir...

cathodique à dit:

je n'ai pas fait des essais poussés.

juste ajout d'un fournisseur avec la première combobox et ça l'ajoute au tableau.

Cliquez pour agrandir...

eric72 à dit:

Ca m'inquiète d'autant plus...
Merci quand même!

Cliquez pour agrandir...

ChTi160 à dit:

Bonjour le Fil
chez moi même erreur !
Jean marie

Cliquez pour agrandir...

eric72 à dit:

dans l'évènement Afterupdate de ma combobox (code déjà utilisé à maintes reprises sans problème), mais cette fois il plante au moment d'ajouter la ligne

Cliquez pour agrandir...

fanch55 à dit:

Salut,
L'erreur se produit car les comboboxs 1 à 5 sont liés par des rowsource à la table des fournisseurs, ce qui interdit la mise à jour de la table
Il faut donc rompre ce lien, mettre à jour la table et rétablir les liens .

VB:

Private Sub CbFournisseur1_Enter()
    CbFournisseur1.DropDown
End Sub
Private Sub CbFournisseur1_AfterUpdate()
    If CbFournisseur1 = "" Then Exit Sub
   
    With ThisWorkbook.Sheets("Données").[TbFournisseur[Fournisseur]] 'nom de la feuille
        Set f = .Find(Me.CbFournisseur1.Value, , , xlWhole)
        If f Is Nothing Then ' Le fournisseur n'existe pas, on doit l'ajouter
            ' Rupture des liens avec la table des fournisseurs qu'on doit mettre à jour
            For i = 1 To 5: Me.Controls("CbFournisseur" & i).RowSource = "": Next
            Idx = .ListObject.ListRows.Add().Index
            .Rows(Idx) = Me.CbFournisseur1.Value
            ' Rétablissement des liens avec la table des fournisseurs
            For i = 1 To 5: Me.Controls("CbFournisseur" & i).RowSource = .ListObject.Name: Next
        End If
    End With

End Sub

Cliquez pour agrandir...

W = Array(CbFournisseur1)
.ListRows.Add.Range.Cells(1).Resize(, 1) = W ' On ajoute la ligne à la base

If Found Then

Else
    With ws.ListObjects("TbFournisseur")
    Dim W
'...
'...

• Ne serait-il pas plus judicieux de passer par un Factory Pattern pour initialiser les Tableaux et colonnes des tableaux ? Cela éviterait de se peller tout le code si changement de noms.
• Mettre Option Explicit en tête de module évitera pas mal de problèmes par la suite.
• L'option Compare Text n'est valable que lors de l'utilisation de l'opérateur LIKE, l'opérateur "=" recherche une correspondance exacte, si vous voulez omettre la casse alors il faut lui préférer StrComp.
• L'utilisation de RowSource pour les listes et listes déroulantes ne peut que poser des problèmes.
• Dans ces lignes :
  VB:

  Set rng = f.Range("A2:F" & f.[a1000000].End(xlUp).Row)

  vous pouvez utiliser les avantages des tableaux structurés.
• La logique du formulaire est à revoir, vous avez un bouton enregistrer et un bouton Editer, alors que vous voulez que les lignes s'ajoutent sur un AfterUpdate.
• Il est conseillé de travailler avec un ID pour les tableaux, l'ajout de lignes avec un nom identique, et une adresse différente par exemple doit-être possible.

'@Folder "System"
Option Explicit

Public Type FournisseurColumns
    ID As String
    Nom As String
    Adresse As String
    Ville As String
End Type

Public Type ArticleColumns
    Reference As String
    Designation As String
    PrixUnitaire As String
End Type

'@Description "Retourne un objet ListObject s'il existe sinon retourne Nothing"
Private Function getListObject( _
        ByVal ListName As String, _
        Optional ByVal Workbook As Excel.Workbook _
        ) As Excel.ListObject

    Dim localWorkbook As Excel.Workbook
    Set localWorkbook = Workbook
    If localWorkbook Is Nothing Then Set localWorkbook = ThisWorkbook
 
    With localWorkbook
        Do
            Dim CounterSheets As Integer
            CounterSheets = CounterSheets + 1
            Dim CounterListObjects As Integer: CounterListObjects = 0
            With .Worksheets(CounterSheets)
                Do While CounterListObjects < .ListObjects.Count And getListObject Is Nothing
                    CounterListObjects = CounterListObjects + 1
                    If StrComp(ListName, .ListObjects(CounterListObjects).Name, vbTextCompare) = 0 Then Set getListObject = .ListObjects(CounterListObjects)
                Loop
            End With
        Loop While CounterSheets < .Worksheets.Count And getListObject Is Nothing
    End With
End Function

'@Description "Initialise le tableau des données des fournisseurs."
Public Function InitTabFournisseurs( _
       Optional ByVal Reset As Boolean _
       ) As ListObject
 
    Static item As ListObject
    If item Is Nothing Or Reset Then
        Set item = getListObject("TbFournisseur")
    End If
    Set InitTabFournisseurs = item
End Function

'@Description "Initialise le tableau des données de base."
Public Function InitTabAchats( _
       Optional ByVal Reset As Boolean _
       ) As ListObject
 
    Static item As ListObject
    If item Is Nothing Or Reset Then
        Set item = getListObject("TbAchats")
    End If
    Set InitTabAchats = item
End Function

'@Description "Initialise le tableau des comptes."
Public Function InitTabComptes( _
       Optional ByVal Reset As Boolean _
       ) As ListObject
 
    Static item As ListObject
    If item Is Nothing Or Reset Then
        Set item = getListObject("TbComptes")
    End If
    Set InitTabComptes = item
End Function

'@Description "Retourne les noms de colonnes pour le tableau TbFournisseur."
Public Function GetFournisseurColumnNames( _
       ) As FournisseurColumns

    Dim Columns As FournisseurColumns
    With Columns
        .ID = "ID"
        .Nom = "Nom"
        .Adresse = "Adresse"
        .Ville = "Ville"
    End With
    GetFournisseurColumnNames = Columns
End Function

Private Sub CbFournisseur1_AfterUpdate()
 
    Dim lstO As Excel.ListObject
    Set lstO = Factory.InitTabFournisseurs
    If Not lstO Is Nothing Then
     
        ' // Initialisation des entêtes de colonnes du tableau fournisseurs
        Dim ColumnsNames As Factory.FournisseurColumns
        ColumnsNames = Factory.GetFournisseurColumnNames
 
        With lstO
            If .ListRows.Count > 0 Then
                Dim Found As Boolean
                Dim itemRange As Excel.Range
                For Each itemRange In .ListColumns(ColumnsNames.Nom).DataBodyRange
                    If StrComp(itemRange.Value, Me.CbFournisseur1.Value) = 0 Then Found = True: Exit For
                Next itemRange
            End If 

                'Todo "La logique du formulaire est à revoir
                If Not Found Then
                    Dim newRow As Excel.ListRow
                    Set newRow = .ListRows.Add
                    With newRow
                        '.Range(1).Value = CbFournisseur1.Value ' // Affectation directe
                        .Range(.Parent.ListColumns(ColumnsNames.ID).Index).Value = GetMaxId(lstO, ColumnsNames.ID) ' // Affectation par le nom de colonne
                        .Range(.Parent.ListColumns(ColumnsNames.Nom).Index).Value = CbFournisseur1.Text ' // Affectation par le nom de colonne
'                        .Range(.Parent.ListColumns(ColumnsNames.Adresse).Index).Value = vbNullString
'                        .Range(.Parent.ListColumns(ColumnsNames.Ville).Index).Value = vbNullString
                    End With
                End If
             
        End With
    End If
End Sub

Private Function GetMaxId( _
        ByVal Table As Excel.ListObject, _
        Optional ByVal Column As String = "ID", _
        Optional ByVal Increment As Boolean = True _
        ) As Long

    If Not Table Is Nothing Then
        With Table
            If .ListRows.Count = 0 Then
                GetMaxId = 1
            Else
                GetMaxId = Application.WorksheetFunction.Max(Table.ListColumns(Column).DataBodyRange) + IIf(Increment, 1, 0)
            End If
        End With
    End If
End Function

fanch55 à dit:

Salut,
L'erreur se produit car les comboboxs 1 à 5 sont liés par des rowsource à la table des fournisseurs, ce qui interdit la mise à jour de la table
Il faut donc rompre ce lien, mettre à jour la table et rétablir les liens .

VB:

Private Sub CbFournisseur1_Enter()
    CbFournisseur1.DropDown
End Sub
Private Sub CbFournisseur1_AfterUpdate()
    If CbFournisseur1 = "" Then Exit Sub
   
    With ThisWorkbook.Sheets("Données").[TbFournisseur[Fournisseur]] 'nom de la feuille
        Set f = .Find(Me.CbFournisseur1.Value, , , xlWhole)
        If f Is Nothing Then ' Le fournisseur n'existe pas, on doit l'ajouter
            ' Rupture des liens avec la table des fournisseurs qu'on doit mettre à jour
            For i = 1 To 5: Me.Controls("CbFournisseur" & i).RowSource = "": Next
            Idx = .ListObject.ListRows.Add().Index
            .Rows(Idx) = Me.CbFournisseur1.Value
            ' Rétablissement des liens avec la table des fournisseurs
            For i = 1 To 5: Me.Controls("CbFournisseur" & i).RowSource = .ListObject.Name: Next
        End If
    End With

End Sub

Cliquez pour agrandir...

cathodique à dit:

mais tu ne nous expliques pas les circonstances du plantage. Etant donné que cela fonctionner.
Je reconnais une adaptation du code de feu Jacques Boisgontier.
Tu n'as pas déclaré toutes tes variables, ce qui pourrait te jouer des tours.

Je t'avais dit que sur Excel 2010, lorsqu'il s'agit uniquement de la 1ère combobox, le code ne plante pas et ajoute le nouveau fournisseur.
Mais ce n'est pas le cas pour les autres comboboxs.

Personnellement, je trouve que c'est une très mauvaise idée de rajouter le nouveau fournisseur avant la validation via le bouton.
En effet, tu utilises l'évènement "CbFournisseur1_AfterUpdate".

Chez-moi le code plante lorsque je clique dans la listbox. Que veux-tu faire exactement en utilisant ce contrôle?
Nous sommes prêt à t'aider, mais il faudrait nous expliquer les tenants et aboutissants de ton projet.

edit: oups! on s'est croisé. Salut

Cliquez pour agrandir...

Valtrase à dit:

Bonjour à tous,
Petites questions, pourquoi faire difficile quand on peut faire simple ? Dans ces lignes :

VB:

W = Array(CbFournisseur1)
.ListRows.Add.Range.Cells(1).Resize(, 1) = W ' On ajoute la ligne à la base

Le tableau Fournisseurs ne comporte qu'une colonne alors pourquoi faire des Resize et autres Array() ?
Pourquoi laisser libre la condition vrai dans :

Code:

If Found Then

Else
    With ws.ListObjects("TbFournisseur")
    Dim W
'...
'...

• Ne serait-il pas plus judicieux de passer par un Factory Pattern pour initialiser les Tableaux et colonnes des tableaux ? Cela éviterait de se peller tout le code si changement de noms.
• Mettre Option Explicit en tête de module évitera pas mal de problèmes par la suite.
• L'option Compare Text n'est valable que lors de l'utilisation de l'opérateur LIKE, l'opérateur "=" recherche une correspondance exacte, si vous voulez omettre la casse alors il faut lui préférer StrComp.
• L'utilisation de RowSource pour les listes et listes déroulantes ne peut que poser des problèmes.
• Dans ces lignes :
  VB:

  Set rng = f.Range("A2:F" & f.[a1000000].End(xlUp).Row)

  vous pouvez utiliser les avantages des tableaux structurés.
• La logique du formulaire est à revoir, vous avez un bouton enregistrer et un bouton Editer, alors que vous voulez que les lignes s'ajoutent sur un AfterUpdate.
• Il est conseillé de travailler avec un ID pour les tableaux, l'ajout de lignes avec un nom identique, et une adresse différente par exemple doit-être possible.

Donc si l'on considère un module Factory de la sorte :

VB:

'@Folder "System"
Option Explicit

Public Type FournisseurColumns
    ID As String
    Nom As String
    Adresse As String
    Ville As String
End Type

Public Type ArticleColumns
    Reference As String
    Designation As String
    PrixUnitaire As String
End Type

'@Description "Retourne un objet ListObject s'il existe sinon retourne Nothing"
Private Function getListObject( _
        ByVal ListName As String, _
        Optional ByVal Workbook As Excel.Workbook _
        ) As Excel.ListObject

    Dim localWorkbook As Excel.Workbook
    Set localWorkbook = Workbook
    If localWorkbook Is Nothing Then Set localWorkbook = ThisWorkbook
   
    With localWorkbook
        Do
            Dim CounterSheets As Integer
            CounterSheets = CounterSheets + 1
            Dim CounterListObjects As Integer: CounterListObjects = 0
            With .Worksheets(CounterSheets)
                Do While CounterListObjects < .ListObjects.Count And getListObject Is Nothing
                    CounterListObjects = CounterListObjects + 1
                    If StrComp(ListName, .ListObjects(CounterListObjects).Name, vbTextCompare) = 0 Then Set getListObject = .ListObjects(CounterListObjects)
                Loop
            End With
        Loop While CounterSheets < .Worksheets.Count And getListObject Is Nothing
    End With
End Function

'@Description "Initialise le tableau des données des fournisseurs."
Public Function InitTabFournisseurs( _
       Optional ByVal Reset As Boolean _
       ) As ListObject
   
    Static item As ListObject
    If item Is Nothing Or Reset Then
        Set item = getListObject("TbFournisseur")
    End If
    Set InitTabFournisseurs = item
End Function

'@Description "Initialise le tableau des données de base."
Public Function InitTabAchats( _
       Optional ByVal Reset As Boolean _
       ) As ListObject
   
    Static item As ListObject
    If item Is Nothing Or Reset Then
        Set item = getListObject("TbAchats")
    End If
    Set InitTabAchats = item
End Function

'@Description "Initialise le tableau des comptes."
Public Function InitTabComptes( _
       Optional ByVal Reset As Boolean _
       ) As ListObject
   
    Static item As ListObject
    If item Is Nothing Or Reset Then
        Set item = getListObject("TbComptes")
    End If
    Set InitTabComptes = item
End Function

'@Description "Retourne les noms de colonnes pour le tableau TbFournisseur."
Public Function GetFournisseurColumnNames( _
       ) As FournisseurColumns

    Dim Columns As FournisseurColumns
    With Columns
        .ID = "ID"
        .Nom = "Nom"
        .Adresse = "Adresse"
        .Ville = "Ville"
    End With
    GetFournisseurColumnNames = Columns
End Function

La méthode AfterUpdate pourait ressembler à ceci :

VB:

Private Sub CbFournisseur1_AfterUpdate()
   
    Dim lstO As Excel.ListObject
    Set lstO = Factory.InitTabFournisseurs
    If Not lstO Is Nothing Then
       
        ' // Initialisation des entêtes de colonnes du tableau fournisseurs
        Dim ColumnsNames As Factory.FournisseurColumns
        ColumnsNames = Factory.GetFournisseurColumnNames
   
        With lstO
            If .ListRows.Count > 0 Then
                Dim Found As Boolean
                Dim itemRange As Excel.Range
                For Each itemRange In .ListColumns(ColumnsNames.Nom).DataBodyRange
                    If StrComp(itemRange.Value, Me.CbFournisseur1.Value) = 0 Then Found = True: Exit For
                Next itemRange
               
                'Todo "La logique du formulaire est à revoir
                If Not Found Then
                    Dim newRow As Excel.ListRow
                    Set newRow = .ListRows.Add
                    With newRow
                        '.Range(1).Value = CbFournisseur1.Value ' // Affectation directe
                        .Range(.Parent.ListColumns(ColumnsNames.ID).Index).Value = GetMaxId(lstO, ColumnsNames.ID) ' // Affectation par le nom de colonne
                        .Range(.Parent.ListColumns(ColumnsNames.Nom).Index).Value = CbFournisseur1.Text ' // Affectation par le nom de colonne
'                        .Range(.Parent.ListColumns(ColumnsNames.Adresse).Index).Value = vbNullString
'                        .Range(.Parent.ListColumns(ColumnsNames.Ville).Index).Value = vbNullString
                    End With
                End If
               
            End If
        End With
    End If
End Sub

Cliquez pour agrandir...