Diviser les différentes lignes d'une cellule en plusieurs lignes

**emma31** · 31/07/2023, 17h15

Bonjour,

Je suis désolée si la question a été posée mais je ne trouve pas la réponse.

Dans un tableau excel, j'ai une cellule qui contient une liste de nom prénom.
Exemple : Cellule A1 =
Anne Dupont
Laurent Martin
Isabelle Duprès
Sylvie Bijoux
Albert Dupontel

Je souhaite avoir chaque nom prénom sur une ligne différente.

Résultat Cellule :
A1 Anne Dupont
A2 Laurent Martin
A3 Isabelle Duprès
A4 Sylvie Bijoux
A5 Albert Dupontel

La fonction convertir ne me convient pas. Je ne sais pas comment faire.

Je remercie la communauté pour votre aide.

Cordialement,

emma31

**ARTURO83** · 01/08/2023, 07h51

Bonjour,

Essayez cette macro:

Code :

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

1
2
3
4
Sub Separation()
  Noms = Split(Range("A1"), Chr(10))
  Range("A1").Resize(UBound(Noms) + 1).Value = Application.Transpose(Noms)
End Sub

Cdlt

**emma31** · 01/08/2023, 09h56

Envoyé par ARTURO83

Bonjour,

Essayez cette macro:

Code :

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

1
2
3
4
Sub Separation()
  Noms = Split(Range("A1"), Chr(10))
  Range("A1").Resize(UBound(Noms) + 1).Value = Application.Transpose(Noms)
End Sub

Cdlt

Bonjour,

Cela n'a pas fonctionné. J'ai mis le fichier en pièce jointe pour être plus précise dans mon besoin.

En tous cas merci pour aide.

Cordialement.

**ARTURO83** · 01/08/2023, 10h51

Par rapport au fichier joint, pourriez-vous définir plus clairement votre besoin?

**emma31** · 01/08/2023, 11h22

Envoyé par ARTURO83

Par rapport au fichier joint, pourriez-vous définir plus clairement votre besoin?

Dans la feuille 1 du classeur, il y a en ligne 7, 9 et 11 une cellule qui contient plusieurs Nom Prénom (service).

Je souhaietrai avoir une ligne par personne avec son Nom Prénom (service).

Est-ce que c'est possible ?

Cordialement.

**ARTURO83** · 01/08/2023, 12h40

Voilà le code

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
Option Explicit
 
Sub Separation()
    Dim f1 As Worksheet, f2 As Worksheet
    Dim DerLig_f1 As Long, i As Long, j As Long, Col_f2 As Long, Lig_f2 As Long, DerCol_f1 As Long
    Dim Noms
    Application.ScreenUpdating = False
    Set f1 = Sheets("Feuille 1")
    Set f2 = Sheets("Resultats")
    DerLig_f1 = f1.Range("A" & Rows.Count).End(xlUp).Row
    DerCol_f1 = f1.Range("C6").End(xlToRight).Column
    f2.Cells.ClearContents
    f1.Cells.Replace What:=",", Replacement:=")"
    f1.Cells.Replace What:="/", Replacement:=")"
    f1.Cells.Replace What:="))", Replacement:=")"
    Lig_f2 = 1
    For i = 7 To DerLig_f1 Step 2
        Col_f2 = 1
        For j = 3 To DerCol_f1
            On Error Resume Next
            Noms = Split(f1.Cells(i, j), ")")
            If Err.Number = 0 Then
                f2.Cells(Lig_f2, Col_f2).Resize(UBound(Noms) + 1).Value = Application.Transpose(Noms)
                On Error GoTo 0
            End If
            Col_f2 = Col_f2 + 1
        Next j
        Lig_f2 = f2.Range("A1").CurrentRegion.Rows.Count + 1
    Next i
    With f2.Cells
        .WrapText = False
        .HorizontalAlignment = xlLeft
        .VerticalAlignment = xlTop
        .EntireColumn.AutoFit
        .EntireRow.AutoFit
        .WrapText = True
    End With
    Set f1 = Nothing
    Set f2 = Nothing
End Sub

Je viens de voir après coup qu'il manque la parenthèse fermante dans la feuille "Résultats", si vous y tenez, je regarderai ça plus tard,

emma31_Diviser les différentes lignes d'une cellule en plusieurs lignes.xlsm

Cdlt

**ARTURO83** · 01/08/2023, 13h12

Petit complément, après l'export dans la feuille "Résultats", les noms sont triés par ordre alphabétique, et les doublons sont supprimés pour chaque colonne.

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
Option Explicit
    Dim f1 As Worksheet, f2 As Worksheet
    Dim DerLig_f1 As Long, i As Long, j As Long, Col_f2 As Long, Lig_f2 As Long, DerCol_f1 As Long
 
Sub Separation()
    Dim Noms
    Application.ScreenUpdating = False
    Set f1 = Sheets("Feuille 1")
    Set f2 = Sheets("Resultats")
    DerLig_f1 = f1.Range("A" & Rows.Count).End(xlUp).Row
    DerCol_f1 = f1.Range("C6").End(xlToRight).Column
    f2.Cells.ClearContents
    f1.Cells.Replace What:=",", Replacement:=")"
    f1.Cells.Replace What:="/", Replacement:=")"
    f1.Cells.Replace What:="))", Replacement:=")"
    Lig_f2 = 1
    For i = 7 To DerLig_f1 Step 2
        Col_f2 = 1
        For j = 3 To DerCol_f1
            On Error Resume Next
            Noms = Split(f1.Cells(i, j), ")")
            If Err.Number = 0 Then
                f2.Cells(Lig_f2, Col_f2).Resize(UBound(Noms) + 1).Value = Application.Transpose(Noms)
                On Error GoTo 0
            End If
            Col_f2 = Col_f2 + 1
        Next j
        Lig_f2 = f2.Range("A1").CurrentRegion.Rows.Count + 1
    Next i
    f2.Select
    Tri_Suppr_Doublons
    With f2.Cells
        .WrapText = False
        .HorizontalAlignment = xlLeft
        .VerticalAlignment = xlTop
        .EntireColumn.AutoFit
        .EntireRow.AutoFit
        .WrapText = True
    End With
    Set f1 = Nothing
    Set f2 = Nothing
End Sub
 
Sub Tri_Suppr_Doublons()
    Application.DisplayAlerts = False
    For i = 1 To Lig_f2
        For j = 1 To DerCol_f1 - 2
            f2.Cells(i, j) = LTrim(f2.Cells(i, j))
        Next j
    Next i
    For i = 1 To DerCol_f1 - 2
        ActiveWorkbook.Worksheets("Resultats").Sort.SortFields.Clear
        ActiveWorkbook.Worksheets("Resultats").Sort.SortFields.Add2 Key:=Range(f2.Cells(1, i), f2.Cells(Lig_f2, i)), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        With ActiveWorkbook.Worksheets("Resultats").Sort
            .SetRange Range(f2.Cells(1, i), f2.Cells(Lig_f2, i))
            .Header = xlNo
            .SortMethod = xlPinYin
            .Apply
        End With
        Range(f2.Cells(1, i), f2.Cells(Lig_f2, i)).RemoveDuplicates Columns:=1, Header:=xlNo
    Next i
End Sub

**emma31** · 01/08/2023, 14h31

Envoyé par ARTURO83

Petit complément, après l'export dans la feuille "Résultats", les noms sont triés par ordre alphabétique, et les doublons sont supprimés pour chaque colonne.

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
Option Explicit
    Dim f1 As Worksheet, f2 As Worksheet
    Dim DerLig_f1 As Long, i As Long, j As Long, Col_f2 As Long, Lig_f2 As Long, DerCol_f1 As Long
 
Sub Separation()
    Dim Noms
    Application.ScreenUpdating = False
    Set f1 = Sheets("Feuille 1")
    Set f2 = Sheets("Resultats")
    DerLig_f1 = f1.Range("A" & Rows.Count).End(xlUp).Row
    DerCol_f1 = f1.Range("C6").End(xlToRight).Column
    f2.Cells.ClearContents
    f1.Cells.Replace What:=",", Replacement:=")"
    f1.Cells.Replace What:="/", Replacement:=")"
    f1.Cells.Replace What:="))", Replacement:=")"
    Lig_f2 = 1
    For i = 7 To DerLig_f1 Step 2
        Col_f2 = 1
        For j = 3 To DerCol_f1
            On Error Resume Next
            Noms = Split(f1.Cells(i, j), ")")
            If Err.Number = 0 Then
                f2.Cells(Lig_f2, Col_f2).Resize(UBound(Noms) + 1).Value = Application.Transpose(Noms)
                On Error GoTo 0
            End If
            Col_f2 = Col_f2 + 1
        Next j
        Lig_f2 = f2.Range("A1").CurrentRegion.Rows.Count + 1
    Next i
    f2.Select
    Tri_Suppr_Doublons
    With f2.Cells
        .WrapText = False
        .HorizontalAlignment = xlLeft
        .VerticalAlignment = xlTop
        .EntireColumn.AutoFit
        .EntireRow.AutoFit
        .WrapText = True
    End With
    Set f1 = Nothing
    Set f2 = Nothing
End Sub
 
Sub Tri_Suppr_Doublons()
    Application.DisplayAlerts = False
    For i = 1 To Lig_f2
        For j = 1 To DerCol_f1 - 2
            f2.Cells(i, j) = LTrim(f2.Cells(i, j))
        Next j
    Next i
    For i = 1 To DerCol_f1 - 2
        ActiveWorkbook.Worksheets("Resultats").Sort.SortFields.Clear
        ActiveWorkbook.Worksheets("Resultats").Sort.SortFields.Add2 Key:=Range(f2.Cells(1, i), f2.Cells(Lig_f2, i)), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        With ActiveWorkbook.Worksheets("Resultats").Sort
            .SetRange Range(f2.Cells(1, i), f2.Cells(Lig_f2, i))
            .Header = xlNo
            .SortMethod = xlPinYin
            .Apply
        End With
        Range(f2.Cells(1, i), f2.Cells(Lig_f2, i)).RemoveDuplicates Columns:=1, Header:=xlNo
    Next i
End Sub

Surtement que je m'y prends mal car quand j'exécute la macro, j'ai un message d'erreur : Erreur de compilation : variable non définie.

Je vous remercie infiniement pour le temps que vous prenez pour mon problème excell.

Cordialement

**ARTURO83** · 01/08/2023, 15h40

Bizarre, pourtant toutes les variables sont déclarées et chez moi je n'ai pas ce problème.
Revoici le fichier avec quelques modifications. S'il subsiste des noms en apparence en doublons, c'est qu'au niveau de la "feuille 1" ils sont enregistrés quelque peu différemment.
emma31_Diviser les différentes lignes d'une cellule en plusieurs lignes_2.xlsm

Cdlt

**jurassic pork** · 02/08/2023, 07h16

Hello,
je n'ai peut-être pas bien compris ce que tu veux faire mais si c'est en fait dans une même cellule de ranger les personnes une par ligne, voici une macro qui réalise cela.
Le principe :
1 - On sélectionne la cellule ou les cellules où l'on veut faire la manipulation (multi sélection possible) ou bien on force la sélection (décommenter la ligne avec Union dans le code)) puis on lance la macro
2 - La macro va lire chaque cellule sélectionnée en effectuant le traitement suivant :
1 - Si une personne n'a pas de service renseigné on lui met (?) derrière son nom. Elimination des virgules et des vbLf.
2 - Mise en place d'une expression régulière qui extrait des morceaux constitués du nom prénom suivi par quelque chose entre parenthèses.
3 - les morceaux sont assemblés ensemble en ajoutant un vblf après chaque morceau.
4 - On réécrit la cellule en traitement avec les morceaux réassemblés.

Pour l'instant la macro ne fait pas la substitution dans les cellules. Il faut décommenter la ligne 'rng.Value = pour le faire.
Il y a des cellules avec double nom séparé par un / . Comme je ne sais pas ce qu'il faut faire dans ce cas-là j'ai laissé. Il doit y avoir aussi d'autres cas "foireux".
Voici la macro :

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
Sub Separation()
    Dim strTest As String, res As String
    Dim regEx As Object, Matches As Object, Match As Object
    Dim rng As Range
        'Union(Range("C7:AT7"), Range("C9:AT9"), Range("C11:AT11")).Select
        For Each rng In Selection
        strTest = rng.Value
        strTest = Replace(strTest, "),", ") ")
        strTest = Replace(strTest, vbLf, " ")
        strTest = Replace(strTest, ",", " (?) ")
        ' Création de l'objet RegExp
        Set regEx = CreateObject("VBScript.RegExp")
        regEx.Global = True
        regEx.IgnoreCase = True
        regEx.Pattern = "[,]*(.*?\(.*?\))" ' Expression régulière pour trouver  *(*)
        ' Recherche d'une correspondance avec l'expression régulière
        Set Matches = regEx.Execute(strTest)
        res = ""
        For Each Match In Matches
          'Debug.Print Trim(Match.submatches(0))
          res = res + Trim(Match.submatches(0)) + vbLf
        Next
        If res <> "" Then
           Debug.Print "==================="
           Debug.Print Left(res, Len(res) - 1)
           'rng.Value = Left(res, Len(res) - 1)
        End If
    Next rng
End Sub

Et voilà ce que cela donne :
Nom : Sepa.gif
Affichages : 342
Taille : 201,1 Ko

Ami calmant, J.P

**emma31** · 02/08/2023, 10h58

Envoyé par jurassic pork

Hello,
je n'ai peut-être pas bien compris ce que tu veux faire mais si c'est en fait dans une même cellule de ranger les personnes une par ligne, voici une macro qui réalise cela.
Le principe :
1 - On sélectionne la cellule ou les cellules où l'on veut faire la manipulation (multi sélection possible) ou bien on force la sélection (décommenter la ligne avec Union dans le code)) puis on lance la macro
2 - La macro va lire chaque cellule sélectionnée en effectuant le traitement suivant :
1 - Si une personne n'a pas de service renseigné on lui met (?) derrière son nom. Elimination des virgules et des vbLf.
2 - Mise en place d'une expression régulière qui extrait des morceaux constitués du nom prénom suivi par quelque chose entre parenthèses.
3 - les morceaux sont assemblés ensemble en ajoutant un vblf après chaque morceau.
4 - On réécrit la cellule en traitement avec les morceaux réassemblés.

Pour l'instant la macro ne fait pas la substitution dans les cellules. Il faut décommenter la ligne 'rng.Value = pour le faire.
Il y a des cellules avec double nom séparé par un / . Comme je ne sais pas ce qu'il faut faire dans ce cas-là j'ai laissé. Il doit y avoir aussi d'autres cas "foireux".
Voici la macro :

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
Sub Separation()
    Dim strTest As String, res As String
    Dim regEx As Object, Matches As Object, Match As Object
    Dim rng As Range
        'Union(Range("C7:AT7"), Range("C9:AT9"), Range("C11:AT11")).Select
        For Each rng In Selection
        strTest = rng.Value
        strTest = Replace(strTest, "),", ") ")
        strTest = Replace(strTest, vbLf, " ")
        strTest = Replace(strTest, ",", " (?) ")
        ' Création de l'objet RegExp
        Set regEx = CreateObject("VBScript.RegExp")
        regEx.Global = True
        regEx.IgnoreCase = True
        regEx.Pattern = "[,]*(.*?\(.*?\))" ' Expression régulière pour trouver  *(*)
        ' Recherche d'une correspondance avec l'expression régulière
        Set Matches = regEx.Execute(strTest)
        res = ""
        For Each Match In Matches
          'Debug.Print Trim(Match.submatches(0))
          res = res + Trim(Match.submatches(0)) + vbLf
        Next
        If res <> "" Then
           Debug.Print "==================="
           Debug.Print Left(res, Len(res) - 1)
           'rng.Value = Left(res, Len(res) - 1)
        End If
    Next rng
End Sub

Et voilà ce que cela donne :
Nom : Sepa.gif
Affichages : 342
Taille : 201,1 Ko

Ami calmant, J.P

Je voulais vraiment te remercier pour ton aide précieuse et ta grande disponibilté. J'ai beaucoup appris et ça m'a aidé.
C'est vraiment super.

Un grand merci.

Emma

Diviser les différentes lignes d'une cellule en plusieurs lignes [XL-2010]

Excel

Discussions similaires

Partager

Partager