Private Sub ListBox1_Click()'bebere
Dim tbl() As String
'ReDim tbl(0 To 7, 0 To i)
If Me.ListBox1 <> "" Then
Me.ListBox2.Clear
i = 0
With Worksheets("Feuil1")
Set c = .Range("E6:E" & .Range("E65536").End(xlUp).Row).Find(ListBox1, LookIn:=xlValues)
If Not c Is Nothing Then
firstAddress = c.Address
Do
If c.Offset(, 3).Interior.ColorIndex = 3 Or c.Offset(, 3).Interior.ColorIndex = 6 Then 'date1
ReDim Preserve tbl(0 To 9, 0 To i)
tbl(0, i) = c
tbl(1, i) = c.Offset(, 1)
tbl(2, i) = c.Offset(, 2)
tbl(3, i) = c.Offset(, 3)
tbl(4, i) = c.Offset(, 4)
tbl(5, i) = c.Offset(, 5)
tbl(6, i) = c.Offset(, 6)
tbl(7, i) = c.Offset(, 7)
tbl(8, i) = c.Offset(, 8)
tbl(9, i) = "date1"
i = i + 1
End If
Set c = .Range("E6:E" & .Range("E65536").End(xlUp).Row).FindNext(c)
Loop While Not c Is Nothing And c.Address <> firstAddress
End If
Set c = .Range("E6:E" & .Range("E65536").End(xlUp).Row).Find(ListBox1, LookIn:=xlValues)
If Not c Is Nothing Then
firstAddress = c.Address
Do
If c.Offset(, 7).Interior.ColorIndex = 3 Or c.Offset(, 7).Interior.ColorIndex = 6 Then 'date2
ReDim Preserve tbl(0 To 9, 0 To i)
tbl(0, i) = c
tbl(1, i) = c.Offset(, 1)
tbl(2, i) = c.Offset(, 2)
tbl(3, i) = c.Offset(, 3)
tbl(4, i) = c.Offset(, 4)
tbl(5, i) = c.Offset(, 5)
tbl(6, i) = c.Offset(, 6)
tbl(7, i) = c.Offset(, 7)
tbl(8, i) = c.Offset(, 8)
tbl(9, i) = "date2"
i = i + 1
End If
Set c = .Range("E6:E" & .Range("E65536").End(xlUp).Row).FindNext(c)
Loop While Not c Is Nothing And c.Address <> firstAddress
End If
End With
If UBound(tbl, 2) > 0 Then
Me.ListBox2.List = Application.Transpose(tbl)
Else
Me.ListBox2.AddItem
Me.ListBox2.Column() = tbl
End If
End If
End Sub