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
115
116
117
118
119
120
| Option Explicit
Sub Affecter()
Dim LastLig As Long, i As Long, k As Long, m As Long
Dim Str As String, Tmp As String, Res() As String
Dim j As Byte, c As Byte
Dim Wbk As Workbook
Dim Dico As Object
Dim Tb, Param
Application.ScreenUpdating = False
'On remplit dans la variable tableau T les données des lignes A à E de Tabelle1
'Travailler avec les variables tableau est plus rapide que travailler directement sur les cellules
With Worksheets("Tabelle1")
'Ligne de la dernière cellule remplie de la colonne A
LastLig = .Cells(.Rows.Count, 1).End(xlUp).Row
Tb = .Range("A2:E" & LastLig)
End With
'On crée un dictionnaire qui comportera tous les paramètres (sans doublons)
Set Dico = CreateObject("Scripting.dictionary")
'on parcour notre tableau Tb
For i = 1 To LastLig - 1
'on parcour les colonnes 2 (Parametre) et 3(Exit-to)
For c = 2 To 3
'Dans Str nous recupérons les données de la colonne 2
Str = Tb(i, c)
'Si elle n'est pas vide
If Str <> "" Then
'on supprime le retour à la ligne
Str = Replace(Str, Chr(10), "")
'on supprime les espaces
Str = Replace(Str, " ", "")
'Pour ton exemple, la ligne 2 donne Str=Iv_volt=4;Card=8;Ampli=7Hz;
'Ici, dans la variable tableau Param, on récupères les données qui sont séparés par ;
'Regarde l'aide sur Split
Param = Split(Str, ";")
'On aura Param(0): Iv_volt=4 Param(1): Card=8 Param(2): Ampli=7Hz et Param(3): vide
'On parcours tous les éléments du tableau Param (excepté le dernier vide: d'où le Unound(Param)-1)
For j = 0 To UBound(Param) - 1
'Dans Tmp on récupère ka paramètre (sans le =??)
'Dans notre cas, Tmp succéssivement (pour i=2): Iv_volt Card et Ampli
Tmp = Split(Param(j), "=")(0)
'Si Tmp n'existe pas encore dans notre dictionnaire
If Not Dico.Exists(Tmp) Then
'on l'ajoute
Dico.Add Tmp, Tmp
'On redimensionne le tableau résultat Res
k = k + 1
ReDim Preserve Res(1 To 3, 1 To k)
Res(1, k) = Tmp
Res(2, k) = Tb(i, 5)
Res(3, k) = Left(Tb(i, 1), 4)
'Dans Res, En 1ère colonne: le paramètre Tmp, la 2ème colonne: l'ensemble des projets et en 3ème colonne, les 4premières lettres de l'ID
Else
'ici c'est Tmp existe déjà dans le dictionnaire, on cherche l'item correspondant dans la 1ère colonne de Res
'On ajoute dans la colonne 2, l'ensmble des projets séparés par les projets déjà existant par un saut de ligne
'Remarque, à ce stade, on aura certains projets qui se répèteneraient
For m = 1 To k
If Res(1, m) = Tmp Then
Res(2, m) = Res(2, m) & Chr(10) & Tb(i, 5)
Exit For
End If
Next m
End If
Next j
End If
Next c
Next i
'on supprime notre dictionnaire,
Set Dico = Nothing
'Appel de la procédure qui supprime les doublons de la 2 colonne de Res (celle des projets)
SupDoub Res
'On insère les données finales de notre tableau Res dans la feuille Tabelle2 à partir de la 2ème ligne
'k étant le nombre de paramètres trouvés
'Enregistrement dans un nouveau fichier
Set Wbk = Workbooks.Add(1)
With Wbk
With .Worksheets(1)
.Range("A1:C1") = Array("Nom", "Projet", "TestNom")
.Range("A2").Resize(k, 3) = Application.Transpose(Res)
End With
.SaveAs ThisWorkbook.Path & "\Fichier" & Format(Date, "ddmmyyhhnn") & ".xls"
.Close
End With
Set Wbk = Nothing
End Sub
'Ici le ByRef est primordial, on modifie dans notre tableau
'Regarde dans les tutos de DVP
Private Sub SupDoub(ByRef Tblo)
Dim Str As String
Dim i As Long
Dim j As Byte
Dim Resul
For i = 1 To UBound(Tblo, 2)
'Dans Str on aura tous les projets (avec doublons) dans chaque cellule de la 2ème colonne de notre tableau
Str = Tblo(2, i)
If Str <> "" Then
'on efface cette cellule
Tblo(2, i) = Empty
'on isole les données séparés par un retours à la ligne
Resul = Split(Str, Chr(10))
'on parcours le tableau obtenu
For j = 0 To UBound(Resul)
'si l'item Resul(j) n'xiste pas encore dans la nouvelle données de Tblo(2,i)
'on l'ajoute, sinon, il existe déjà. Ceci pour supprimer ls doublons
If InStr(Tblo(2, i), Resul(j)) = 0 Then Tblo(2, i) = Tblo(2, i) & Chr(10) & Resul(j)
Next j
'on récupère les données sans doublons (la première occurence est un retour à la ligne
'd'où l'utilisation de Mid
Tblo(2, i) = Mid(Tblo(2, i), 2)
End If
Next i
End Sub |
