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
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
| Option Explicit
'Active la Référence Microsoft Scripting Runtime
Sub Traiter()
Const Cible As String = "E1"
Dim Str As String, Code As String, Res()
Dim LastLig As Long, i As Long, n As Long
Dim j As Integer, m As Integer, Nb As Integer
Dim MonDico As New Scripting.Dictionary
Dim ItemDico As New Scripting.Dictionary
Dim Tb
Application.ScreenUpdating = False
With Feuil1
LastLig = .Cells(.Rows.Count, "A").End(xlUp).Row
Tb = .Range("A2:B" & LastLig)
For i = 1 To UBound(Tb, 1)
Str = Tb(i, 1)
Code = SupprNum(Tb(i, 2))
If Code = "UNI6" Or Code = "UDI6" Then Code = "UDI6/UNI6"
If InStr(Str, "-") Then
If Not ItemDico.Exists(Code) And Code <> "" Then ItemDico.Add Code, Code
Str = Left(Str, InStrRev(Str, "-") - 1)
If Not MonDico.Exists(Str) Then
MonDico.Add Str, "," & Code
Else
MonDico(Str) = MonDico(Str) & "," & Code
End If
End If
Next i
m = ItemDico.Count
If m > 0 Then
n = MonDico.Count
If n > 0 Then
ReDim Res(1 To n + 1, 1 To m + 3)
Res(1, 1) = "S"
Res(1, 2) = "P"
Res(1, m + 3) = "Positions Libres"
For j = 0 To m - 1
Res(1, j + 3) = ItemDico.Items(j)
Next j
For i = 0 To n - 1
Str = MonDico.Keys(i)
Nb = Indx(Tb, Str)
Res(i + 2, 1) = Mid(Str, 3)
Res(i + 2, 2) = UBound(Split(MonDico.Items(i), ","))
For j = 0 To m - 1
Res(i + 2, j + 3) = CompteItems(MonDico.Items(i), ItemDico.Items(j))
Next j
Res(i + 2, m + 3) = Nb
Next i
Set MonDico = Nothing
.Range(Cible).Resize(n + 1, m + 3) = Res
.Range(Cible).Resize(n + 1, m + 3).Sort Key1:=.Range(Cible), Order1:=xlAscending, Header:=xlYes
End If
End If
End With
End Sub
Private Function SupprNum(ByVal Str As String) As String
Dim Rg As Object
Set Rg = CreateObject("vbscript.Regexp")
With Rg
.Pattern = "^\d{0,3}"
.Global = True
SupprNum = .Replace(Str, "")
End With
Set Rg = Nothing
End Function
Private Function CompteItems(ByVal Str As String, ByVal Txt As String) As Integer
Dim i As Integer, n As Integer
Dim Tb
If Len(Str) > 0 Then
Str = Mid(Str, 2)
If InStr(Str, ",") Then
Tb = Split(Str, ",")
For i = LBound(Tb) To UBound(Tb)
If UCase(Tb(i)) = UCase(Txt) Then n = n + 1
Next i
End If
End If
CompteItems = n
End Function
Private Function Indx(ByVal Tb, ByVal Str As String) As Integer
Dim i As Long
Dim j As Integer, Mx As Integer, S As Integer
Dim Trouve As Boolean
For i = 1 To UBound(Tb, 1)
If Left(Tb(i, 1), InStrRev(Tb(i, 1), "-") - 1) Like Str Then
Mx = Application.Max(Mx, Val(Mid(Tb(i, 1), InStrRev(Tb(i, 1), "-") + 1)))
End If
Next i
For j = 0 To Mx
For i = 1 To UBound(Tb, 1)
If Tb(i, 1) = Str & "-" & j Then
Trouve = True
Exit For
End If
Next i
If Not Trouve Then
S = S + 1
Else
Trouve = False
End If
Next j
Indx = S
End Function |
Extraction de données par sous ensemble
Répondre avec citation
Envoyé par mercatog
Partager