Transposition d'informations dans une table

Version imprimable

01/05/2018, 16h04
ChrisMaire

Transposition d'informations dans une table

Bonjour, j'ai une table avec dans une cellule des informations dont le nombre est variable et dont les valeurs sont séparées par des virgules; ce que je voudrais c'est pouvoir séparer les valeurs de ma colonne puis les transposer pour pouvoir ensuite travailler mes infos dans des tableaux croisés dynamique ...
Donc pour résumer voici ce que j'ai :

Cell1 Cell2 |Cell3

A Val1, Val2 xx

B Val1 yy

C Val2, Val3, Val4 zz

je voudrais arriver à :

Cell1 Cell2 Cell3

A Val1 xx

A Val2 xx

B Val1 yy

C Val2 zz

C Val3 zz

C Val4 zz

Merci d'avance et bonne journée
01/05/2018, 17h06
Jean-Philippe André

Salut,

t'est-il possible de passer par du code VBA pour faire le traitement voulu ?
01/05/2018, 17h13
ChrisMaire

Oui sans problème

Cell1	Cell2	\|Cell3
A	Val1, Val2	xx
B	Val1	yy
C	Val2, Val3, Val4	zz

Cell1	Cell2	Cell3
A	Val1	xx
A	Val2	xx
B	Val1	yy
C	Val2	zz
C	Val3	zz
C	Val4	zz

En passant par une boucle sur chaque ligne, tu peux avoir un traitement dans cette idée.

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
dim wshorig As worksheet
dim wshdest As worksheet
'choix des feuilles origine et destination
Dim j As Integer
j=1
For i=1 To 100 'bornes à définir
Dim v as Variant
v= Split(wshorig.Range("B"&i).value,",")
For k=LBound(v) TO Lbound(v)
wshdest.Range("A" & j).value =wshorig.Range("A"&i).value
wshdest.Range("B" & j).value =v(k)
wshdest.Range("C" & j).value =wshorig.Range("C"&i).value
Next k
Next i

Citation:

Envoyé par ChrisMaire

Bonjour,

A tester et à adapter :

Code:

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
 
Option Explicit
 
Sub SpliterEtTransposer(ByVal FeuilleSource As Worksheet, ByVal FeuilleCible As Worksheet)
 
Dim MaChaine As Variant
Dim Cellule As Range
Dim DerniereLigne As Long, LigneCibleEnCours As Long
Dim I As Integer
 
        LigneCibleEnCours = 1
        With FeuilleSource
             DerniereLigne = .Cells(.Rows.Count, 1).End(xlUp).Row
             For Each Cellule In .Range("A1:A" & DerniereLigne)
                 MaChaine = Split(Cellule.Offset(0, 1), ",")
                    For I = LBound(MaChaine) To UBound(MaChaine)
                        With FeuilleCible
                             .Cells(LigneCibleEnCours, 1) = Cellule
                             .Cells(LigneCibleEnCours, 2) = Trim(MaChaine(I))
                             .Cells(LigneCibleEnCours, 3) = Cellule.Offset(0, 2)
                             LigneCibleEnCours = LigneCibleEnCours + 1
                        End With
                    Next I
            Next Cellule
        End With
End Sub
 
Sub TestSpliterEtTransposer()
 
    SpliterEtTransposer Sheets("Source"), Sheets("Cible")
 
End Sub

01/05/2018, 17h29
ChrisMaire

Merci Messieurs .. je me mets au test !

J'ai adapté le code d'Éric et ça fonctionne parfaitement !
03/05/2018, 23h11
ChrisMaire

Et si je voulais merger les cellules de la premiere colonne, est-ce compliqué ?
Donc passer de :

Cell1 Cell2 |Cell3

A Val1, Val2 xx

B Val1 yy

C Val2, Val3, Val4 zz

à

A Val1 xx

Val2 xx

B Val1 yy

C Val2 zz

Val3 zz

Val4 zz

Merci une nouvelle fois !

Cell1	Cell2	\|Cell3
A	Val1, Val2	xx
B	Val1	yy
C	Val2, Val3, Val4	zz

Citation:

Envoyé par ChrisMaire

Code:

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
 
Option Explicit
 
Sub SpliterEtTransposer(ByVal FeuilleSource As Worksheet, ByVal FeuilleCible As Worksheet, ByVal AvecFusion As Boolean)
 
Dim MaChaine As Variant
Dim Cellule As Range
Dim DerniereLigne As Long, LigneCibleEnCours As Long, PremiereLigneFusion As Long
Dim I As Integer
 
        LigneCibleEnCours = 1
        With FeuilleSource
             DerniereLigne = .Cells(.Rows.Count, 1).End(xlUp).Row
             For Each Cellule In .Range("A1:A" & DerniereLigne)
                 MaChaine = Split(Cellule.Offset(0, 1), ",")
                 If UBound(MaChaine) > 0 Then PremiereLigneFusion = LigneCibleEnCours
                    For I = LBound(MaChaine) To UBound(MaChaine)
                        With FeuilleCible
                             .Cells(LigneCibleEnCours, 1) = Cellule
                             .Cells(LigneCibleEnCours, 2) = Trim(MaChaine(I))
                             .Cells(LigneCibleEnCours, 3) = Cellule.Offset(0, 2)
                             If AvecFusion = True And UBound(MaChaine) > 0 Then
                                With .Range(.Cells(PremiereLigneFusion, 1), .Cells(LigneCibleEnCours, 1))
                                     Application.DisplayAlerts = False
                                     .Merge
                                     .HorizontalAlignment = xlLeft
                                     .VerticalAlignment = xlCenter
                                     Application.DisplayAlerts = True
                                End With
                             End If
                             LigneCibleEnCours = LigneCibleEnCours + 1
                        End With
                    Next I
            Next Cellule
        End With
End Sub
 
Sub TestSpliterEtTransposer()
 
    SpliterEtTransposer Sheets("Source"), Sheets("Cible"), True
 
End Sub

04/05/2018, 21h45
ChrisMaire

Réponse parfaite une nouvelle fois ... Merci Eric !