Discussion :

[Stefpro]

Bonjour à tous ,
Je suis un débutant en VBA et je doit écrire une Macro qui me permet d’automatiser ce que j’ai l’abitude de faire avec les clic manuels. Voila mon problème.Je dois écrire un programe qui me permet de classer un fichier Excel en fonction des variables que contient le fichier et les différent projets dans lesquel les variables sont utilisées.
J'ai joint à ce problème un fichier Excel dans lequel la 1ere feuille est celle en désordre et le seconde feuille est le fichier. Donc j'ai commencé a classer manuellement.
J'ai essayé d'automatiser ce classement avec les Macros mais cela est trop limité et ça fait deja 1mois que je cherche comment faire une application qui va me gérer ce processus mais je n'y arrive vraiment pas.
Voici ce que j'ai déjà pu faire .

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
Sub Makro1()
'
' Makro1 Makro
 
    Range("B3").Select
    ActiveCell.FormulaR1C1 = "Iv_volt = 4;" & Chr(10) & "Card = 8;" & Chr(10) & "Ampli = 7Hz;"
    With ActiveCell.Characters(Start:=1, Length:=35).Font
        .Name = "Calibri"
        .FontStyle = "Standard"
        .Size = 11
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ThemeColor = xlThemeColorLight1
        .TintAndShade = 0
        .ThemeFont = xlThemeFontMinor
    End With
    Sheets("Tabelle2").Select
    Range("A2").Select
    ActiveCell.FormulaR1C1 = "Iv_volt"
    Sheets("Tabelle1").Select
    Range("E3").Select
    ActiveCell.FormulaR1C1 = _
        "Hardw.2x" & Chr(10) & "Hadrw.3.8" & Chr(10) & "Hardw.1.2" & Chr(10) & "Hardw.9.0" & Chr(10) & "Hardw.0.8" & Chr(10) & "Hardw.7.9"
    With ActiveCell.Characters(Start:=1, Length:=58).Font
        .Name = "Calibri"
        .FontStyle = "Standard"
        .Size = 11
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ThemeColor = xlThemeColorLight1
        .TintAndShade = 0
        .ThemeFont = xlThemeFontMinor
    End With
    Sheets("Tabelle2").Select
    Range("B2").Select
    ActiveCell.FormulaR1C1 = _
        "Hardw.2x" & Chr(10) & "Hadrw.3.8" & Chr(10) & "Hardw.1.2" & Chr(10) & "Hardw.9.0" & Chr(10) & "Hardw.0.8" & Chr(10) & "Hardw.7.9"
    With ActiveCell.Characters(Start:=1, Length:=58).Font
        .Name = "Calibri"
        .FontStyle = "Standard"
        .Size = 11
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ThemeColor = xlThemeColorLight1
        .TintAndShade = 0
        .ThemeFont = xlThemeFontMinor
    End With
    Sheets("Tabelle1").Select
    Range("A3").Select
    ActiveCell.FormulaR1C1 = "Sozb1908"
    Sheets("Tabelle2").Select
    Range("C2").Select
    ActiveCell.FormulaR1C1 = "Sozb"
    Sheets("Tabelle1").Select
    Range("B3").Select
    ActiveCell.FormulaR1C1 = "Iv_volt = 4;" & Chr(10) & "Card = 8;" & Chr(10) & "Ampli = 7Hz;"
    With ActiveCell.Characters(Start:=1, Length:=35).Font
        .Name = "Calibri"
        .FontStyle = "Standard"
        .Size = 11
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ThemeColor = xlThemeColorLight1
        .TintAndShade = 0
        .ThemeFont = xlThemeFontMinor
    End With
    Sheets("Tabelle2").Select
    Range("A3").Select
    ActiveCell.FormulaR1C1 = "Card"
    Sheets("Tabelle1").Select
    Range("E3").Select
    ActiveCell.FormulaR1C1 = _
        "Hardw.2x" & Chr(10) & "Hadrw.3.8" & Chr(10) & "Hardw.1.2" & Chr(10) & "Hardw.9.0" & Chr(10) & "Hardw.0.8" & Chr(10) & "Hardw.7.9"
    With ActiveCell.Characters(Start:=1, Length:=58).Font
        .Name = "Calibri"
        .FontStyle = "Standard"
        .Size = 11
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ThemeColor = xlThemeColorLight1
        .TintAndShade = 0
        .ThemeFont = xlThemeFontMinor
    End With
    Sheets("Tabelle2").Select
    Range("B3").Select
    ActiveCell.FormulaR1C1 = _
        "Hardw.2x" & Chr(10) & "Hadrw.3.8" & Chr(10) & "Hardw.1.2" & Chr(10) & "Hardw.9.0" & Chr(10) & "Hardw.0.8" & Chr(10) & "Hardw.7.9"
    With ActiveCell.Characters(Start:=1, Length:=58).Font
        .Name = "Calibri"
        .FontStyle = "Standard"
        .Size = 11
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ThemeColor = xlThemeColorLight1
        .TintAndShade = 0
        .ThemeFont = xlThemeFontMinor
    End With
    Sheets("Tabelle1").Select
    Range("A3").Select
    ActiveCell.FormulaR1C1 = "Sozb1908"
    Sheets("Tabelle2").Select
    Range("C3").Select
    ActiveCell.FormulaR1C1 = "Sozb"
    Sheets("Tabelle1").Select
    Range("B3").Select
    ActiveCell.FormulaR1C1 = "Iv_volt = 4;" & Chr(10) & "Card = 8;" & Chr(10) & "Ampli = 7Hz;"
    With ActiveCell.Characters(Start:=1, Length:=35).Font
        .Name = "Calibri"
        .FontStyle = "Standard"
        .Size = 11
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ThemeColor = xlThemeColorLight1
        .TintAndShade = 0
        .ThemeFont = xlThemeFontMinor
    End With
    Sheets("Tabelle2").Select
    Range("A4").Select
    ActiveCell.FormulaR1C1 = "Ampli "
    Sheets("Tabelle1").Select
    Range("E3").Select
    ActiveCell.FormulaR1C1 = _
        "Hardw.2x" & Chr(10) & "Hadrw.3.8" & Chr(10) & "Hardw.1.2" & Chr(10) & "Hardw.9.0" & Chr(10) & "Hardw.0.8" & Chr(10) & "Hardw.7.9"
    With ActiveCell.Characters(Start:=1, Length:=58).Font
        .Name = "Calibri"
        .FontStyle = "Standard"
        .Size = 11
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ThemeColor = xlThemeColorLight1
        .TintAndShade = 0
        .ThemeFont = xlThemeFontMinor
    End With
    Sheets("Tabelle2").Select
    Range("B4").Select
    ActiveCell.FormulaR1C1 = _
        "Hardw.2x" & Chr(10) & "Hadrw.3.8" & Chr(10) & "Hardw.1.2" & Chr(10) & "Hardw.9.0" & Chr(10) & "Hardw.0.8" & Chr(10) & "Hardw.7.9"
    With ActiveCell.Characters(Start:=1, Length:=58).Font
        .Name = "Calibri"
        .FontStyle = "Standard"
        .Size = 11
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ThemeColor = xlThemeColorLight1
        .TintAndShade = 0
        .ThemeFont = xlThemeFontMinor
    End With
    Sheets("Tabelle1").Select
    Range("A3").Select
    ActiveCell.FormulaR1C1 = "Sozb1908"
    Sheets("Tabelle2").Select
    Range("C4").Select
    ActiveCell.FormulaR1C1 = "Sozb"
    Sheets("Tabelle1").Select
    Range("B4").Select
    ActiveCell.FormulaR1C1 = _
        "Iv_volt = 2;" & Chr(10) & "Card = 8;" & Chr(10) & "Coptr_v = 1;" & Chr(10) & "Exel_1 =0;" & Chr(10) & "Time = 10S;"
    With ActiveCell.Characters(Start:=1, Length:=58).Font
        .Name = "Calibri"
        .FontStyle = "Standard"
        .Size = 11
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ThemeColor = xlThemeColorLight1
        .TintAndShade = 0
        .ThemeFont = xlThemeFontMinor
    End With
    Sheets("Tabelle2").Select
    Range("A5").Select
    ActiveCell.FormulaR1C1 = "Coptr_v"
    Sheets("Tabelle1").Select
    Range("E4").Select
    ActiveCell.FormulaR1C1 = "Hardw.2x" & Chr(10) & "Hardw.3.8" & Chr(10) & "Hardw.1.2" & Chr(10) & "Hardw.2.x"
    With ActiveCell.Characters(Start:=1, Length:=38).Font
        .Name = "Calibri"
        .FontStyle = "Standard"
        .Size = 11
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ThemeColor = xlThemeColorLight1
        .TintAndShade = 0
        .ThemeFont = xlThemeFontMinor
    End With
    Sheets("Tabelle2").Select
    Range("B5").Select
    ActiveCell.FormulaR1C1 = "Hardw.2x" & Chr(10) & "Hardw.3.8" & Chr(10) & "Hardw.1.2" & Chr(10) & "Hardw.2.x"
    With ActiveCell.Characters(Start:=1, Length:=38).Font
        .Name = "Calibri"
        .FontStyle = "Standard"
        .Size = 11
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ThemeColor = xlThemeColorLight1
        .TintAndShade = 0
        .ThemeFont = xlThemeFontMinor
    End With
    Sheets("Tabelle1").Select
    Range("A4").Select
    ActiveCell.FormulaR1C1 = "Sozb176"
    Sheets("Tabelle2").Select
    Range("A6").Select
    ActiveCell.FormulaR1C1 = ""
    Range("C5").Select
    ActiveCell.FormulaR1C1 = "Sozb"
    Range("D4").Select
    Sheets("Tabelle1").Select
    ActiveWindow.SmallScroll Down:=-21
    Application.WindowState = xlMinimized
End Sub

Merci beaucoup pour votre aide, j'en suis vraiment à bout .
Cordialement Stephane

[Daniel.C]

Bonjour,

Il ne fallait pas attendre un mois !
Par contre, tu devrais détailler précisément ce que tu fais manuellement, parce que je ne vois pas comment tu arrives à ton résultat.

[Stefpro]

Salut Daniel,
merci deja d'avoir intervenu sur ma question.en effet ce que je veu faire est ceci.
j'ai un fichier exel dont j'ai joint le fichier a ma question sur le Forum.
je doit ecrire un Code en VBA qui me permet d'aller dans la colone Parametre de la feuille1 chercher dans chaque cellule de cette colone une variable ,la copier ,aller dans la feuille2, la coller dans la colone "Nom" ensuite revenir dans la feuille1 dans la cellule ou cette variable a eté copier ,copier sur la meme ligne les " N-Projekt" corespondant a la cette variable et la coller a colone Projekt de la feuille2 .et ainsi de suite pour tous les variables de ma feuille1.
comme je l'ait dit en jetant un petit coup d'œil dans le fichier exel dont j'ai joint a ma question .vous verrez sur la 1er feuille les variables classé en désordre et sur la 2eme feuille vous verrez comment je l'ai classer manuelement (clic).ceque j'aimerais faire c7 d'atomatiser cella grace a une application VBA .
merci bcp pour votre aide.

__________________
Cordialement.

Stephane

[Daniel.C]

Bonjour,

Mon souci est ce que tu entends par "variable", où je retrouve dans la feuille 2 lv_volt, Card, Ampli... Comment déterminer la variable ? dans la colonne Paramètre" de Feuille 1, je trouve en I3 lv_volt, Card, Ampli; est-ce que ce sont des variables ? Quoi mettre dans la colonne Testnom ?

[Stefpro]

en efait I3 lv_volt, Card, Ampli...ect... coe tu la dit sont en effet des parametres qui sont dans la colone "Parametre" et aussi dans la colone "Exit-to ".
c'est parametre doivent etre copier un par un et classer dans la colone "Nom" de la feuille2 et ainsi que les nom des projets dans dans quelle ils apparaissent.
pour la colone "Testnom" c7 claire se sera tjr Sozb car il corespond a l'ID de chaque parametre.
merci bcp pour votre aide.

__________________
Cordialement.

Stephane

[Daniel.C]

Comment séparer les noms de projet qui apparaissent les uns à la suite des autres dans la même cellule ? est-ce qu'il commencent tous par "Hardw" ?

[Stefpro]

la je ne sait pas comment les séparer ,tous commence par "Hardw" mais sauf que les numeraux a la fin change en fonction des parametres qui sont dans la colone "Parametre" et aussi dans la colone "Exit-to ".

__________________
Cordialement.

Stephane

[Daniel.C]

Précise donc comment tu remplis la colonne "Testnom" ? d'après la colonne ID en ôtant les chiffres ?

[mercatog]

Question non claire, réponse de même

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
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 Dico As Object
Dim Tb, Param
Dim j As Byte
 
Application.ScreenUpdating = False
With Worksheets("Tabelle1")
    LastLig = .Cells(.Rows.Count, 1).End(xlUp).Row
    Tb = .Range("A2:E" & LastLig)
End With
 
Set Dico = CreateObject("Scripting.dictionary")
For i = 1 To LastLig - 1
    Str = Tb(i, 2)
    If Str <> "" Then
        Str = Replace(Str, Chr(10), "")
        Str = Replace(Str, " ", "")
        Param = Split(Str, ";")
        For j = 0 To UBound(Param) - 1
            Tmp = Split(Param(j), "=")(0)
            If Not Dico.Exists(Tmp) Then
                Dico.Add Tmp, Tmp
                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)
            Else
                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 i
Set Dico = Nothing
 
SupDoub Res
Worksheets("Tabelle2").Range("A2").Resize(k, 3) = Application.Transpose(Res)
End Sub
 
Private Sub SupDoub(ByRef Tblo)
Dim Str As String
Dim i As Long
Dim j As Byte
Dim Res
 
For i = 1 To UBound(Tblo, 2)
    Str = Tblo(2, i)
    Tblo(2, i) = Empty
    Res = Split(Str, Chr(10))
    For j = 0 To UBound(Res)
        If InStr(Tblo(2, i), Res(j)) = 0 Then Tblo(2, i) = Tblo(2, i) & Chr(10) & Res(j)
    Next j
    Tblo(2, i) = Mid(Tblo(2, i), 2)
Next i
End Sub

[Daniel.C]

Essaie :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
Sub Copie()
    Dim Sh1 As Worksheet, Sh2 As Worksheet, c As Range
    Dim Param As String, Ctr As Long
    Set Sh1 = Sheets("Tabelle1")
    Set Sh2 = Sheets("Tabelle2")
    With Sh2
        .Cells.Clear
        .[A1] = "Nom"
        .[B1] = "Paramet"
        .[C1] = "Testnom"
        .Columns(2).WrapText = True
    End With
    With Sh1
        For Each c In .Range(.[B2], .Cells(.Rows.Count, 2).End(xlUp))
            If c <> "" Then
                For Each Item In Split(c.Value, ";")
                    If Item <> "" Then
                    Param = Split(Item, " = ")(0)
                        If Not IsNumeric(Application.Match(Param, Sh2.[A:A], 0)) Then
                            Ctr = Sh2.Cells(65000, 1).End(xlUp).Row + 1
                            Sh2.Cells(Ctr, 1) = Param
                            For Each item2 In Split(c.Offset(, 3), "Hardw")
                                If item2 <> "" Then
                                    If Len(Application.Substitute(Sh2.Cells(Ctr, 2), "Hardw" & item2, "")) = _
                                        Len(Sh2.Cells(Ctr, 2)) Or Sh2.Cells(Ctr, 2) = "" Then
                                        Sh2.Cells(Ctr, 2) = Sh2.Cells(Ctr, 2) & "Hardw" & item2
                                    End If
                                End If
                            Next item2
                        Else
                            Ctr = Application.Match(Param, Sh2.[A:A], 0)
                            For Each item2 In Split(c.Offset(, 3), "Hardw")
                                If item2 <> "" Then
                                    If Len(Application.Substitute(Sh2.Cells(Ctr, 2), "Hardw" & item2, "")) = _
                                        Len(Sh2.Cells(Ctr, 2)) Or Sh2.Cells(Ctr, 2) = "" Then
                                        Sh2.Cells(Ctr, 2) = Sh2.Cells(Ctr, 2) & "Hardw" & item2
                                    End If
                                End If
                            Next item2
                        End If
                    End If
                Next Item
            End If
        Next c
    End With
End Sub

NB. J'attends ta réponse pout Testnom.

[Stefpro]

@ Salut mercatog.
merci bcp pour ton intervention ca ma bcp aidé .mais j'aimerais savoir si tu peu ajouter quelque commentaire dans le code pour le rendre plus compréensible pour un debutant comme moi .
en effet le code est deja persque parfait mais il manque encor quelque petit truck dont je ne sait si tu peu les ajouter.ofait
-le contenu de la colone " Exit-to " doit aussi etre copier comme celui de la colone "Parametre" que tu l'a deja fait

-Dans la copie des " N-Projekt" ,un Hardw ne doit pas etre copier deux fois .par exemple pour le 1er cas de la Tabele2 ("Iv_volt") "Hardw.3.8 " est copier deux fois de suite .

ce sont ses deux problemes qui reste et crois que si cella est réglé mon programme va etre pert a 100% comme je le souhaite il ya un mois


__________________
Cordialement.

Stephane

[mercatog]

-Dans la copie des " N-Projekt" ,un Hardw ne doit pas etre copier deux fois .par exemple pour le 1er cas de la Tabele2 ("Iv_volt") "Hardw.3.8 " est copier deux fois de suite .

Non, tu n'as pas 2 fois Hardw.3.8 pour Iv_volt du moment que dans Tabelle1 tu as Hadrw.3.8 et Hardw.3.8

[Stefpro]

@ Salut Daniel
merci bcp pour ton intervention.ofait
-la colonne "Testnom" doit etre remplir d'après la colonne ID en ôtant les chiffres
-le contenu de la colone " Exit-to " doit aussi etre copier comme celui de la colone "Parametre" que tu l'a deja fait

-Dans la copie des " N-Projekt" ,un Hardw ne doit pas etre copier deux fois .par exemple pour le 1er cas de la Tabele2 ("Iv_volt") "Hardw.3.8 " est copier deux fois de suite .

Mer6 bcp pour votre aide

__________________
Cordialement.

Stephane

@ mercatog,
ok super c'est plutot moi qui ai mail preté attention.je m'excuse ,il ne reste plus donc que le contenu de la colone " Exit-to " qui doit aussi etre copier comme celui de la colone "Parametre" que tu l'a deja fait,et aussi un peu de commentaire dans le code pour un debutant comme moi
merci bcp

__________________
Cordialement.

Stephane

[mercatog]

Pour le commentaire, pas de souci. et après tu devra continuer.
En fait, tes explications sont sommaires, dans le fichier joint, tu n'as jamais fais allusion à la colonne Exit-to. Donc?

[Stefpro]

@ mercatog,
excuse moi vraiment.je suis un nouveau dans le forum et je manque vraiment d'experience pour poser mon probleme.
vraiment excusez moi.
j'en serais ravis des réponses
merci bcp


__________________
Cordialement.

Stephane

[mercatog]

Code que j'avais proposé avec commentaire

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
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 Dico As Object
Dim Tb, Param
Dim j As Byte
 
Application.ScreenUpdating = False
'On remplit dans la variable tableau Tb 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")
    'LAstLig: 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
    'Dans Str nous recupérons les données de la colonne 2
    Str = Tb(i, 2)
    '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, " ", "")
        Debug.Print 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 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
Worksheets("Tabelle2").Range("A2").Resize(k, 3) = Application.Transpose(Res)
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)
    '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)
Next i
End Sub

PS. Nouveau dans le forum, tu es le bienvenu, mais ça n'empêche pas de bien expliquer où ça coince chez toi.
encore faudra que tu t'applique pour mieux avancer. Je crois qu'avec ma proposition toute faite, ça ne t'avance à rien. Mais au moins tu as une idée qu'on peut arriver à quelque chose de potable.

[Daniel.C]

-Dans la copie des " N-Projekt" ,un Hardw ne doit pas etre copier deux fois .par exemple pour le 1er cas de la Tabele2 ("Iv_volt") "Hardw.3.8 " est copier deux fois de suite .

Il n'y a pas de doublon pour ce code, seulement, un faux doublon :
Hardw.2x
Hardw.2.x

mercatog semble tenir la corde; pas besoin d'être deux à bosser

[mercatog]

mercatog semble tenir la corde; pas besoin d'être deux à bosser

Bonsoir Daniel.
Pas du tout, chaque proposition aura sa valeur pour aider l’intéressé.

[Stefpro]

merci bcp pour vos intervetions ca m'aide variment énormment.
@ mercatog merci bcp pour les comentaire sur le code cella a amélioré ma compréheision du code.je vais essayer de faire la suite qui consite a copier le contenu de la colone " Exit-to " qui doit aussi etre copier comme celui de la colone "Parametre" seule et vous dire si vous tenir au courant de l'evolution

__________________
Cordialement.

Stephane

[mercatog]

On ajoutera une petite boucle à l'intérieur sur les colonnes 2 et 3

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
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 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
Worksheets("Tabelle2").Range("A2").Resize(k, 3) = Application.Transpose(Res)
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