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 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64
| Private Sub TextBox1_Change()
On Error Resume Next
Dim i&, fin&, Y&, mem As Boolean, cc() As Variant, bb() As Variant, a&
Application.ScreenUpdating = 0
If TextBox1 = "" Then ListBox1.Clear: Exit Sub '
efface = True 'instanciation de la variable efface=true (critère actif pour effacement de feuille)
ListBox1.Clear: ListBox1.ColumnWidths = "60;80;80;100;80;60;80;65;65;80"
With Feuil4
Y = 1
fin = .Cells.Find("*", , xlValues, , 1, 2, 0).Row
aa = .Range("A2:K" & fin)
End With
For i = 1 To UBound(aa)
aa(i, 11) = i + 5
For a = 1 To UBound(aa, 2)
If aa(i, a) Like "*" & TextBox1 & "*" Then aa(i, 11) = "oui": Y = Y + 1: Exit For
Next a
Next i
If Y = 1 Then Exit Sub
If Y = 2 Then
For i = 1 To UBound(aa)
If aa(i, 11) = "oui" Then
ReDim cc(1, UBound(aa, 2) - 1)
For a = 1 To UBound(cc, 2)
cc(1, a) = aa(i, a)
Next a
Sheets.Add After:=Sheets(Sheets.Count)
Sheets(Sheets.Count).Range("A1:K1").Value = Sheets("BaseClient").Range("A1:K1").Value
Sheets(Sheets.Count).Range(Cells(2, 1), Cells(UBound(cc, 1) + 1, UBound(cc, 2))) = cc
With Sheets(Sheets.Count)
ListBox1.RowSource = "A2:" & .Cells(UBound(cc, 1) + 1, UBound(cc, 2)).Address
End With
mem = 1: Exit For
End If
Next i
Else
ReDim bb(Y - 1, UBound(aa, 2) - 1)
Y = 1
For i = 1 To UBound(aa)
If aa(i, 11) = "oui" Then
For a = 1 To UBound(aa, 2) - 1
bb(Y, a) = aa(i, a)
Next a
Y = Y + 1
End If
Next i
End If
Sheets.Add After:=Sheets(Sheets.Count)
Sheets(Sheets.Count).Range("A1:K1").Value = Sheets("BaseClient").Range("A1:K1").Value
Sheets(Sheets.Count).Range(Cells(2, 1), Cells(UBound(bb, 1) + 1, UBound(bb, 2))) = bb
With Sheets(Sheets.Count)
ListBox1.RowSource = "A2:" & .Cells(UBound(bb, 1) + 1, UBound(bb, 2)).Address
End With
End Sub |