Discussion :

[somosuno]

Bonjour à tous,

Je souhaite transposer une colonne sur plusieurs lignes en ajoutant un retour à la ligne :
- Condition 1 : dès qu'il y a une nouvelle chaine de caractère de type "NomX prénom"

- Condition 2 (sous condition 1) : dès qu'il y a une nouvelle chaine de caractère de type "ABCD1234", ce format étant constant (4 lettres et 4 chiffres)

Un exemple des données à transposer :

Nom1 prenom
ABCD1234
DD/MM/YYYY
Nom2 prenom
EFGH1234
DD/MM/YYYY
DD/MM/YYYY
DD/MM/YYYY
IJKL1234
DD/MM/YYYY
MNOP1234
DD/MM/YYYY
DD/MM/YYYY
Nom3 prenom
QRST1234
DD/MM/YYYY
DD/MM/YYYY
UVWX1234
DD/MM/YYYY
DD/MM/YYYY
DD/MM/YYYY
....

Ce qui donnerait :


ligne1 : Nom1 prenom;ABCD1234;DD/MM/YYYY
ligne2 : Nom2 prenom;EFGH1234;DD/MM/YYYY;DD/MM/YYYY;DD/MM/YYYY
ligne3 : "";IJKL1234;DD/MM/YYYY
ligne4 : "";MNOP1234;DD/MM/YYYY;DD/MM/YYYY
ligne5 : Nom3 prenom;QRST1234;DD/MM/YYYY;DD/MM/YYYY
ligne6 : "";UVWX1234;DD/MM/YYYY;DD/MM/YYYY;DD/MM/YYYY
....

J'ai trouvé un début de solution proposée par boisgontierjacques dans le post suivant :

https://www.developpez.net/forums/d1.../#post10740040

Le code est le suivant :

Code :

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

1
2
3
4
5
6
7
8
9
10
11
12
Sub UneColonnePlusieursLignes()
   Set début = Range("A1")
   fin = [A65000].End(xlUp).Row
   Set dest = Range("C2")
   Taille = 10
   InterVert = 1
   For ligne = 0 To fin Step Taille
      a = début.Offset(ligne).Resize(Taille)
      lignedest = (ligne \ Taille) * InterVert
      dest.Offset(lignedest, 0).Resize(, Taille) = Application.Transpose(a)
   Next ligne
End Sub

Auriez-vous l'amabilité de me le compléter svp?

En vous remerciant par avance pour vos contributions

Cordialement.

[BENNASR]

Bonjour
Personnellement avec mon niveau de débutant VBA je peux pas compléter ton code
Je propose de faire ça avec un dictionnaire
j'ai parti du principe que le clé unique est ce code alphanumérique, si il est précédé par un nom et non pas une date alors on prend ce nom / code et l'ensemble des date qui suivent ce code
s'il s'agit d'une date alors il s'agit d'une nouvelle ligne et mettre (") à la place du nom
A tester avec prudence sur une copie de ton fichier pour munir contre tous risque de perte de données

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
Sub regroup()
Application.ScreenUpdating = False
Dim F1 As Worksheet
Dim f2 As Worksheet
Dim Dercol As Long
Set F1 = Sheets("Base")
Set f2 = Sheets("Resultat")
f2.Cells.ClearContents
Dim i As Long
Set d = CreateObject("Scripting.Dictionary")
    '**********************************************************
    TblBD = F1.Range("A1:A" & F1.Range("A" & Rows.Count).End(xlUp).Row)
    MsgBox UBound(TblBD)
    For i = 1 To UBound(TblBD)
  If IsNumeric(Right(TblBD(i, 1), 4)) And Not IsNumeric(Left(TblBD(i, 1), 2)) Then
        If Not IsDate(TblBD(i - 1, 1)) Then
          clé = TblBD(i - 1, 1) & "|" & TblBD(i, 1)
          Else
          clé = " "" " & "|" & TblBD(i, 1)
          End If
    End If
    On Error Resume Next
    If IsDate(TblBD(i + 1, 1)) Then d(clé) = d(clé) & "|" & Format(TblBD(i + 1, 1), "m/d/yyyy") 'CDate(TblBD(i + 1, 1))
    Next i
 f2.Range("A1").Resize(d.Count) = Application.Transpose(d.keys)
 f2.Range("C1").Resize(d.Count) = Application.Transpose(d.items)
  Application.DisplayAlerts = False
  f2.Range("A1").Resize(d.Count).TextToColumns Other:=1, OtherChar:="|"
  f2.Range("C1").Resize(d.Count).TextToColumns Other:=1, OtherChar:="|"
  f2.Columns("C:C").Delete Shift:=xlToLeft
 
  Application.ScreenUpdating = True
  End Sub

Bonne continuation

[somosuno]

Merci BENNASR.

Je vais essayer de retravailler ton code pour rester sur la même feuille et transposer les données sur une autre cellule/plage!
C'est pas gagné mais je vais essayer

Dès que c'est résolu je mettrai la discussion en tant que tel...

Encore merci

[BENNASR]

n'hésitez pas de revenir si tu n'arrive pas à faire ça
bonne continuatio

[somosuno]

n'hésitez pas de revenir si tu n'arrive pas à faire ça
bonne continuatio

Merci de me débloquer sinon je vais y passer des heures

J'ai besoin de transposer les données sur la même feuille, à partir de la cellule B2 sans toucher à la colonne A qui est ma source de données.

Par ailleurs, est ce que c'est possible de remplacer les " par du vide?

Encore merci pour ton aide

Cordialement,

[BENNASR]

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
Sub regroup()
Application.ScreenUpdating = False
Dim F1 As Worksheet
Dim f2 As Worksheet
Dim Dercol As Long
Set F1 = Sheets("Base")
Dim i As Long
Set d = CreateObject("Scripting.Dictionary")
    '**********************************************************
    TblBD = F1.Range("A1:A" & F1.Range("A" & Rows.Count).End(xlUp).Row)
    MsgBox UBound(TblBD)
    For i = 1 To UBound(TblBD)
    If IsNumeric(Right(TblBD(i, 1), 4)) And Not IsNumeric(Left(TblBD(i, 1), 2)) Then
        If Not IsDate(TblBD(i - 1, 1)) Then
          clé = TblBD(i - 1, 1) & "|" & TblBD(i, 1)
          Else
          clé = "  " & "|" & TblBD(i, 1)
          End If
    End If
    On Error Resume Next
    If IsDate(TblBD(i + 1, 1)) Then d(clé) = d(clé) & "|" & Format(TblBD(i + 1, 1), "m/d/yyyy")
    Next i
 F1.Range("B1").Resize(d.Count) = Application.Transpose(d.keys)
 F1.Range("D1").Resize(d.Count) = Application.Transpose(d.items)
  Application.DisplayAlerts = False
  F1.Range("B1").Resize(d.Count).TextToColumns Other:=1, OtherChar:="|"
  F1.Range("D1").Resize(d.Count).TextToColumns Other:=1, OtherChar:="|"
  F1.Columns("D:D").Delete Shift:=xlToLeft
 
  Application.ScreenUpdating = True
  End Sub