amendement Code RowSource ListBox Plus de 10 colonnes

Version imprimable

1 pièce(s) jointe(s)

Bonjour

ce code

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
Private Sub TextBox1_Change()
On Error Resume Next
Dim V As Integer, Lastrow As Integer
Dim M As String
Dim Q, F
ListBox1.ColumnWidths = "50pt"
ListBox1.Clear
If TextBox1.Text = "" Then
Else
M = TextBox1.Value
        With Sheet2
            Lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
            Set Q = .Range("A6:A" & Lastrow).Find(M)
            If Not Q Is Nothing Then
                F = Q.Address
                Do
                If Application.WorksheetFunction.Search(M, Q, 1) = 1 Then
                    ListBox1.AddItem Q.Value
                    ListBox1.List(V, 0) = Q.Offset(0, 0).Value
                    ListBox1.List(V, 1) = Q.Offset(0, 1).Value
                    ListBox1.List(V, 2) = Q.Offset(0, 2).Value
                    ListBox1.List(V, 3) = Q.Offset(0, 3).Value
                    ListBox1.List(V, 4) = Q.Offset(0, 4).Value
                    ListBox1.List(V, 5) = Q.Offset(0, 5).Value
                    ListBox1.List(V, 6) = Q.Offset(0, 6).Value
                    ListBox1.List(V, 7) = Q.Offset(0, 7).Value
                    ListBox1.List(V, 8) = Q.Offset(0, 8).Value
                    ListBox1.List(V, 9) = Q.Offset(0, 9).Value
                    ListBox1.List(V, 11) = Q.Offset(0, 11).Value
                    ListBox1.List(V, 13) = Q.Offset(0, 13).Value
                    ListBox1.List(V, 14) = Q.Offset(0, 14).Value
                    V = V + 1
                 End If
                Set Q = .Range("A6:A" & Lastrow).FindNext(Q)
                Loop While Not Q Is Nothing And Q.Address <> F
            End If
        End With
      End If
End Sub

Je veux l'apparition des colonnes de données avec la couleur jaune lors de la recherche

témoin Fichiers attaché

Bonjour!

Voilà un petit code:

'solution 1

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
Private Sub TextBox1_Change()
 
    Dim Q As Range, F As Range, T(), i As Integer, n As Integer, M As String, V As Integer, Lastrow As Long
 
    On Error Resume Next
    M = TextBox1.Text
    If M <> "" Then
        Application.ScreenUpdating = False
        With Sheet2
            Lastrow = .UsedRange.Rows.Count
            .Range("A5:A" & Lastrow).AutoFilter 1, M & "*"
            Set Q = .Range("A6:A" & Lastrow).SpecialCells(xlCellTypeVisible)
            If Not Q Is Nothing Then
                ReDim T(1 To Q.Cells.Count, 1 To 15)
                For Each F In Q.Cells
                    If InStr(1, F, M, vbTextCompare) Then
                        n = n + 1
                        For i = 1 To UBound(T, 2)
                            T(n, i) = F.Cells(1, i)
                        Next
                    End If
                Next
                With ListBox1
                    .List = T
                    .ColumnCount = 15
                    .ForeColor = RGB(255, 255, 0)
                End With
                .Range("A6:A" & Lastrow).AutoFilter
                'MsgBox "Chargemement terminé." & Chr(13) & n _
                & " correspondances trouvées.", vbInformation, "Correspondances"
            Else
                Err.Clear
                .Range("A6:A" & Lastrow).AutoFilter
                ListBox1.Clear
                'MsgBox "Aucune correspondance pour: " & M, vbCritical, "Entrée invalide" '
            End If
        End With
        Application.ScreenUpdating = True
    End If
 
End Sub

Bonne journée!

05/01/2013, 14h05
NVCfrm
Petite rectification.
Je m'étais aperçu qu'il y a de la place en haut de la ligne de filtre, pour ne pas utiliser la fonction Instr dans la boucle.La plage filtrée a été modifiée sur A5 au lieu de A6. Ce qui fait que
Code:

1 2 3 'If InStr(1, F, M, vbTextCompare) Then 'End If
n'est pas utile dans le filtre.