Discussion :

[PPN83]

Bonjour,

j'ai 2 colonnes avec x lignes, dans COL1 j'ai des matricules classés dans l'ordre, dans COL2 en face du matricule une lettre. Je souhaiterais que lorsque le matricule est égale au matricule suivant que les lettres correspondantes qui sont donc l'une en dessous de l'autre dans la COL2, soient transposées chacune dans les colonnes à côté mais en ligne.

exemple:
COL 1 COL2
12 a
13 d
13 s
15 z
15 k
15 z
16 p

après transposition

COL1 COL2 COL3 COL4

12 a
13 d s
13 s
15 z k u
15 k
15 u
16 p

l'ordre dans les colonnes 3 à 4 n'a pas d'importance

le test ci dessous n'est pas concluant

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
Sub Transposer()
 
Dim x As Integer
 
For x = 1 To 100
If Cells(x, 1) = Cells(x + 1, 1) Then
Range(Cells(x, 2), Cells(x + 1, 2)).Copy
Cells(x, 3).Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
End If
 
Next x
 
End Sub

Merci d'avance

[PPz78]

bonsoir,

ceci devrait être très proche de ton besoin:

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
Sub xx()
    i_Lg = 1
    Pr_l = 1
    Do
        i_Lg = i_Lg + 1
        If Cells(Pr_l, 1) = Cells(i_Lg, 1) Then
        ' C'est égal, on continue
        Else
        ' C'est différent
            If Pr_l + 1 <> i_Lg Then
                Call Recopie(Pr_l, i_Lg - 1)
                If Cells(i_Lg, 1) = "" Then Exit Do
            End If
            Pr_l = i_Lg
        End If
    Loop
End Sub

avec

Code :

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

1
2
3
4
5
6
7
8
9
 
Sub Recopie(Pr_l, Dr_l)
'   Recopie des valeurs
        Col_recopie = 2
    For l = Pr_l + 1 To Dr_l
        Col_recopie = Col_recopie + 1
        Cells(Pr_l, Col_recopie) = Cells(l, 2)
    Next
End Sub

PPz

[PPN83]

Bonjour PPz78

Merci d'avoir étudié mon problème, je commençais à désespérer, la transposition s'opère impeccable mais à la fin j'ai le message

erreur d'exécution 1004

avec un débogage sur la ligne

Code :

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

If Cells(Pr_l, 1) = Cells(i_Lg, 1) Then

peux tu voir merci d'avance

[mercatog]

Une autre proposition

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
Dim LastLig As Long, i As Long
Dim k As Integer
 
With Sheets("Feuil2")   'Adapte au nom de la feuille
    LastLig = .Cells(Rows.Count, 1).End(xlUp).Row
    For i = LastLig To 3 Step -1
        If .Range("A" & i - 1) = .Range("A" & i) Then
            k = k + 1
            .Range(.Cells(i, 2), .Cells(i, 1 + k)).Copy .Cells(i - 1, 3)
            If k > 1 Then .Range(.Cells(i, 3), .Cells(i, 1 + k)).ClearContents
        Else
            k = 0
        End If
    Next i
End With

[PPN83]

Bonjour,

C'est parfait, merci pour cette intervention Mercatog.
Sans oublier PPz78.
Je vais essayer maintenant de supprimer les lignes qui ne me servent plus à rien, si j'ai un souci je ne manquerais pas de vous contacter

Encore merci

[mercatog]

Ce n'était pas dans la question initiale; sinon

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
Dim LastLig As Long, i As Long
Dim k As Integer
 
With Sheets("Feuil2")   'Adapte au nom de la feuille
    LastLig = .Cells(Rows.Count, 1).End(xlUp).Row
    For i = LastLig To 3 Step -1
        If .Range("A" & i - 1) = .Range("A" & i) Then
            k = k + 1
            .Range(.Cells(i, 2), .Cells(i, 1 + k)).Copy .Range("C" & i - 1)
            .Rows(i).Delete
        Else
            k = 0
        End If
    Next i
End With

[PPz78]

Salut
J'avais mis le test d'arret au mauvais endroit.
Celui-ci fonctionne mieux

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
Sub xx()
    i_Lg = 1
    Pr_l = 1
 
    Do
        i_Lg = i_Lg + 1
        If Cells(Pr_l, 1) = Cells(i_Lg, 1) Then
        ' C'est égal, on continue
        Else
        ' C'est différent
            If Pr_l + 1 <> i_Lg Then
                Call Recopie(Pr_l, i_Lg - 1)
            End If
            Pr_l = i_Lg
            If Cells(i_Lg, 1) = "" Then Exit Do
        End If
 
    Loop
 
End Sub

A+