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
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
| Dim Cll
Private Sub TextBox3_Change()
Dim C, Ck
Dim Cl As Integer
Dim Ar
Dim Arr()
Dim Sh As Worksheet
'------------------------------------------------------------------
Set Sh = Sheets("Sheet2")
With Me
.ListBox1.Clear
Cl = Val(.ComboBox1.ListIndex + 1)
End With
'------------------------------------------------------------------
With Sh
'------------------------------------------------------------------
Ar = .Range("A4:K" & .Cells(.Rows.Count, "C").End(xlUp).Row).Value
'------------------------------------------------------------------
For i = LBound(Ar, 1) To UBound(Ar, 1)
'------------------------------------------------------------------
If Me.CheckBox1.Value = False Then
Ck = InStr(1, Ar(i, Cl), TextBox3, vbTextCompare)
Else
Ck = (InStr(1, Ar(i, Cl), TextBox3, vbTextCompare) And (CDate(Ar(i, 2)) >= CDate(Me.TextBox1) And CDate(Ar(i, 2)) <= CDate(Me.TextBox2)))
End If
'------------------------------------------------------------------
If Ck Then
ii = ii + 1
ReDim Preserve Arr(1 To 12, 1 To ii)
If IsDate(Arr(2, ii)) Then Arr(2, ii) = Format(Arr(2, ii), DtF)
Arr(1, ii) = Ar(i, 1)
Arr(2, ii) = Ar(i, 2)
Arr(3, ii) = Ar(i, 3)
Arr(4, ii) = Ar(i, 4)
End If
Next i
'------------------------------------------------------------------
If ii Then
'------------------------------------------------------------------
Arm = Untl_A(Application.Transpose(Arr))
'------------------------------------------------------------------
If Cll Then
'Ajouter des lignes au tableau
'------------------------------------------------------------------
ReDim Arr(1 To 12, ii + 1 To (ii + 1 + Cll)) '''<<< Ici montre une erreur
For x = LBound(Arm, 1) To UBound(Arm, 1)
Arr(1, x) = Arm(1, x)
Arr(2, x) = Arm(2, x)
Arr(5, x) = Arm(5, x)
Next x
End If
'------------------------------------------------------------------
Me.ListBox1.Column = Arr
'------------------------------------------------------------------
End If
End With
End Sub
Private Function Untl_A(Ar) As Variant
Dim A
Dim Ws As Worksheet
Dim Nw_Arr()
Dim Nw
Dim Aa
Dim i, ii
Set Ws = Sheets("Sheet1")
With Ws
A = .Range("B4:F" & .Cells(.Rows.Count, "D").End(xlUp).Row).Value
r = UBound(Ar, 1) + 1
lc = UBound(Ar, 2)
For i = LBound(Ar, 1) To UBound(Ar, 1)
Nw = Ar(i, 1)
For ii = LBound(A, 1) To UBound(A, 1)
If InStr(1, A(ii, 2), Ar(1, i)) Then
If A(ii, 2) <> "" Then
Cll = Cll + 1
ReDim Preserve Nw_Arr(1 To r, 1 To Cll)
Nw_Arr(1, Cll) = A(ii, 1)
Nw_Arr(2, Cll) = A(ii, 2)
Nw_Arr(5, Cll) = A(ii, 5)
End If
End If
Next ii
Next i
If Cll Then Untl_A = Nw_Arr
End With
End Function |
