VBA : multiples listbox - Question mise en forme conditionnel

Le 22/07/2021 à 11:31
Bonjour,

J'ai deux petits soucis que je n'arrive pas à résoudre. Dans mon document, au niveau de l'onglet "tache modèle" j'ai besoin de créer trois listbox:

- La 1re j'ai réussi à la créer dans la colonne C. C'est une liste à choix multiple et tout marche bien.
- Vu mes problèmes d'affichage, je voulais aussi en créer en colonne I et M (afin que tout le texte apparaisse contrairement aux listes déroulantes de base qui prennent la taille de la colonne). Ça serait des sélections à choix unique. Le problème c'est que quand j'arrive à en faire une l'autre ne marche pas. Dans les macros de la feuille, j'ai mis en commentaire la listbox que j'ai essayé de rajouter en colonne I. Elle fonctionna correctement, mais par contre celle en C ne fonctionna plus... avez-vous une idée de comment m'en sortir?

J'ai un autre petit problème plus "basique". Dans la colonne N selon les résultats je voulais une certaine mise en forme. Du coup j'ai créé les règles ( 1< c'est rouge; entre 0 et 1 orange et >1 vert)... Sauf que je ne sais pas pourquoi, mais il me met toutes les cellules vides en orange ... J'ai essayé de faire une règle pour qu'une cellule vide = blanc, mais ça ne marche pas.

Merci d'avance pour votre aide :)
30travail-ohb.zip (513.01 Ko)
Le 22/07/2021 à 11:55

Bonjour,

Comme ceci:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If (((Target.Column = 3) And (Target.Row > 6))) Then ' si la cellule sélectionnée est en colonne C
        'traitement listbox1
    ElseIf (((Target.Column = 9) And (Target.Row > 6))) Then ' si la cellule sélectionnée est en colonne I
        'traitement listbox2
    ElseIf (((Target.Column = 13) And (Target.Row > 6))) Then ' si la cellule sélectionnée est en colonne M
        'traitement listbox3
    End If
End Sub

Cdlt

Le 23/07/2021 à 09:35

Bonjour,

J'ai teste j'ai eu un message d'erreur "Else sans If"

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If (((ActiveCell.Column = 3) And (ActiveCell.Row > 6))) Then
    ' parametre de la box
    With Me.ListBox1
        .Clear
        .MultiSelect = fmMultiSelectMulti
        .ListStyle = fmListStyleOption
        .Height = 270
        .Width = 75
        .Top = ActiveCell.Top
        .Left = ActiveCell.Offset(0, 1).Left
        For L = 40 To 58 '<- A modifier ici si ajoute des critères
            .AddItem Worksheets("methodologieOHB ").Cells(L, 1)
        Next L
        .Visible = True
    End With
    On Error Resume Next

   'Afficher et selectionné les phrases
    i = 0
    If Worksheets("methodologieOHB").Range("A39").Offset(0, i).End(xlDown).Row = 2 Then
        Me.ListBox1.List = Array(Worksheets("methodologieOHB").Range(Worksheets("methodologieOHB").Range("39").Offset(1, 0), _
        Worksheets("methodologieOHB").Range("A40").Offset(0, i).End(xlDown)).Value, "")
        On Error GoTo 0
        a = VBA.Split(ActiveCell, ";")
        If UBound(a) >= 0 Then
          For i = 0 To Me.ListBox1.ListCount - 1
            If Not IsError(Application.Match(Me.ListBox1.List(i), a, 0)) Then
              bTest = True
              Me.ListBox1.Selected(i) = True
              bTest = False
            End If
          Next
        End If
    End If
    Else
    Me.ListBox1.Visible = False

ElseIf (((ActiveCell.Column = 9) And (ActiveCell.Row > 6))) Then

    ' parametre de la box IC
    With Me.ListBox1
        .Clear
        .MultiSelect = fmMultiSelectSingle
        .ListStyle = fmListStyleOption
        .Height = 90
        .Width = 700
        .Top = ActiveCell.Top
        .Left = ActiveCell.Offset(0, 1).Left
        For L = 68 To 73 '<- A modifier ici si ajoute des critères
            .AddItem Worksheets("methodologieOHB ").Cells(L, 11)
        Next L
        .Visible = True
    End With
    On Error Resume Next

   'Afficher et selectionné IC
    i = 0
    If Worksheets("methodologieOHB").Range("k67").Offset(0, i).End(xlDown).Row = 2 Then
        Me.ListBox1.List = Array(Worksheets("methodologieOHB").Range(Worksheets("methodologieOHB").Range("67").Offset(1, 0), _
        Worksheets("methodologieOHB").Range("k68").Offset(0, i).End(xlDown)).Value, "")
        On Error GoTo 0
        a = VBA.Split(ActiveCell, ";")
        If UBound(a) >= 0 Then
          For i = 0 To Me.ListBox1.ListCount - 1
            If Not IsError(Application.Match(Me.ListBox1.List(i), a, 0)) Then
              bTest = True
              Me.ListBox1.Selected(i) = True
              bTest = False
            End If
          Next
        End If
    End If
    Else
    Me.ListBox1.Visible = False

End If

End Sub
Le 23/07/2021 à 09:59

Bonjour,

Il y a un "Else" qui traîne au milieu, il faut le déplacer à la fin, essayez ceci mais je ne peux pas le tester.

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If ActiveCell.Column = 3 And ActiveCell.Row > 6 Then
        ' parametre de la box
        With Me.ListBox1
            .Clear
            .MultiSelect = fmMultiSelectMulti
            .ListStyle = fmListStyleOption
            .Height = 270
            .Width = 75
            .Top = ActiveCell.Top
            .Left = ActiveCell.Offset(0, 1).Left
            For L = 40 To 58 '<- A modifier ici si ajoute des critères
                .AddItem Worksheets("methodologieOHB ").Cells(L, 1)
            Next L
            .Visible = True
        End With
        On Error Resume Next

       'Afficher et selectionné les phrases
        i = 0
        If Worksheets("methodologieOHB").Range("A39").Offset(0, i).End(xlDown).Row = 2 Then
            Me.ListBox1.List = Array(Worksheets("methodologieOHB").Range(Worksheets("methodologieOHB").Range("39").Offset(1, 0), _
            Worksheets("methodologieOHB").Range("A40").Offset(0, i).End(xlDown)).Value, "")
            On Error GoTo 0
            a = VBA.Split(ActiveCell, ";")
            If UBound(a) >= 0 Then
              For i = 0 To Me.ListBox1.ListCount - 1
                If Not IsError(Application.Match(Me.ListBox1.List(i), a, 0)) Then
                  bTest = True
                  Me.ListBox1.Selected(i) = True
                  bTest = False
                End If
              Next
            End If
        End If

    ElseIf ActiveCell.Column = 9 And ActiveCell.Row > 6 Then
         ' parametre de la box IC
         With Me.ListBox1
             .Clear
             .MultiSelect = fmMultiSelectSingle
             .ListStyle = fmListStyleOption
             .Height = 90
             .Width = 700
             .Top = ActiveCell.Top
             .Left = ActiveCell.Offset(0, 1).Left
             For L = 68 To 73 '<- A modifier ici si ajoute des critères
                 .AddItem Worksheets("methodologieOHB ").Cells(L, 11)
             Next L
             .Visible = True
         End With
         On Error Resume Next

        'Afficher et selectionné IC
         i = 0
         If Worksheets("methodologieOHB").Range("k67").Offset(0, i).End(xlDown).Row = 2 Then
             Me.ListBox1.List = Array(Worksheets("methodologieOHB").Range(Worksheets("methodologieOHB").Range("67").Offset(1, 0), _
             Worksheets("methodologieOHB").Range("k68").Offset(0, i).End(xlDown)).Value, "")
             On Error GoTo 0
             a = VBA.Split(ActiveCell, ";")
             If UBound(a) >= 0 Then
               For i = 0 To Me.ListBox1.ListCount - 1
                 If Not IsError(Application.Match(Me.ListBox1.List(i), a, 0)) Then
                   bTest = True
                   Me.ListBox1.Selected(i) = True
                   bTest = False
                 End If
               Next
             End If
        End If
    Else
        Me.ListBox1.Visible = False
    End If
End Sub

les parenthèses sur ces lignes sont inutiles

If (((ActiveCell.Column = 3) And (ActiveCell.Row > 6))) Then

Cdlt

Le 23/07/2021 à 11:04

Merci pour vos retours

Alors ca fonctionne mais ... j'ai quand même un bug bizarre "Argument ou appel de procédure incorrect". Si je met fin dans la fenêtre j'arrive à sélectionné ma phrases mais dès que je passe a la cellule suivante la fenetre de bug réapparait

Private Sub ListBox1_Change()
  If bTest Then
    Exit Sub
  End If
  sTemp = ""
  For i = 0 To Me.ListBox1.ListCount - 1
    If Me.ListBox1.Selected(i) Then
      sTemp = sTemp & Me.ListBox1.List(i) & ";" '<= comment nommer
    End If
  Next
  sTemp = VBA.Left(sTemp, VBA.Len(sTemp) - 1)
  ActiveCell = sTemp

Le soucis semble venir de

sTemp = VBA.Left(sTemp, VBA.Len(sTemp) - 1)

Le 23/07/2021 à 12:44

Virez "VBA."

Le 23/07/2021 à 13:19

Je suis vraiment désolé, même en virant VBA j'ai toujours le même bug

Le 23/07/2021 à 13:51

Essayez ceci

Private Sub ListBox1_Change()
    If bTest Then
        Exit Sub
    End If
    sTemp = ""
    For i = 0 To Me.ListBox1.ListCount - 1
        On Error Resume Next
        If Me.ListBox1.Selected(i) Then If Err.Number = 0 Then sTemp = sTemp & Me.ListBox1.List(i) & ";"                    '<= comment nommer
        On Error GoTo 0
    Next i

    If sTemp <> "" Then
        sTemp = VBA.Left(sTemp, VBA.Len(sTemp) - 1)
        ActiveCell = sTemp
    End If
End Sub
Le 23/07/2021 à 14:34

Tout fonctionne parfaite maintenant !

Un énorme merci

Rechercher des sujets similaires à "vba multiples listbox question mise forme conditionnel"