Dupliquer ligne entière si virgule dans une cellule

**babacoolcool** · 06/11/2018, 17h46

Bonjour

j’aimerai dupliquer une ligne autant de fois qu'il y a de virgules dans une cellule

AVANT:

AUDIOVISUEL	17/04/2018	Mardi 17/04/2018	08:30	18:30	10:00	V_C125, V_C127	TRAVAUX INSTALLATION ET MAINTENANCE
AUDIOVISUEL	18/04/2018	Mercredi 18/04/2018	08:30	18:30	10:00	V_C125, V_C127	TRAVAUX INSTALLATION ET MAINTENANCE

RESULTAT

AUDIOVISUEL	17/04/2018	Mardi 17/04/2018	08:30	18:30	10:00	V_C125	TRAVAUX INSTALLATION ET MAINTENANCE
AUDIOVISUEL	17/04/2018	Mardi 17/04/2018	08:30	18:30	10:00	V_C127	TRAVAUX INSTALLATION ET MAINTENANCE
AUDIOVISUEL	18/04/2018	Mercredi 18/04/2018	08:30	18:30	10:00	V_C127	TRAVAUX INSTALLATION ET MAINTENANCE
AUDIOVISUEL	18/04/2018	Mercredi 18/04/2018	08:30	18:30	10:00	V_C125	TRAVAUX INSTALLATION ET MAINTENANCE

merci d'avance

Irène

Invité · 07/11/2018, 06h51

Envoyé par babacoolcool

Bonjour,

A tester et à adapter :

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 Test()
 
Dim I As Long, LigneEncours As Long
Dim AireATester As Range, CelluleATester As Range
Dim J As Integer, NbRepetitions As Integer
 
    With ActiveSheet
         LigneEncours = 4
         Set AireATester = .Range("G2:G3")
         For Each CelluleATester In AireATester
             NbRepetitions = UBound(ListeEntreVirgules(CelluleATester.Value))
             If NbRepetitions > 0 Then
                For J = 1 To NbRepetitions
                    CelluleATester.EntireRow.Copy Destination:=.Cells(LigneEncours, 1)
                    LigneEncours = LigneEncours + 1
                Next J
             End If
         Next CelluleATester
   End With
 
End Sub
 
 
Function ListeEntreVirgules(ByRef ContenuCelluleG As String) As Variant
 
  ListeEntreVirgules = Split(ContenuCelluleG, ",")
 
End Function

**babacoolcool** · 09/11/2018, 10h01

Bonjour
Merci pour ton aide mais je n'y arrive pas

Invité · 09/11/2018, 10h12

Envoyé par babacoolcool

Quel est ton problème ?
Mets en ligne un fichier exemple.

**babacoolcool** · 09/11/2018, 11h55

Le résultat obtenu est uniquement une duplication de la ligne quand la cellule contient une virgule. Par exemple:

22/08/2016	Lundi 22/08/2016	7:45:00	22:45:00	15:00:00	P_C110, P_C108
22/08/2016	Lundi 22/08/2016	7:45:00	22:45:00	15:00:00	P_C110, P_C108

Invité · 09/11/2018, 11h57

Envoyé par babacoolcool

Le plus simple est de mettre un fichier en ligne sans données confidentielles.

**OrDonc** · 09/11/2018, 14h40

Salut
Pour traiter plusieurs lignes, voici un EXEMPLE d'utilisation d'un Tableau* de la plage concernée :

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
Option Explicit
Private Sub CS_Click() 
 Dim R As Range, nb As Long, A, k As Byte, L As Long, n As Byte
 Application.ScreenUpdating = 0     'écran figé
  For Each R In [Tbo[C5]]
    nb = [Tbo].Rows.Count                    'nombre de lignes à traiter
    If R Like "*,*" Then                          'si présence de la virgule
      A = Split(R, ",")                             'array des termes
      k = UBound(A)                              'nombre de termes
      L = R.Row - [Tbo].Row + 1             'ligne du Tableau (pas de l'onglet !)
      For n = 1 To k + 1                         'boucle sur le nombre de copies
        [Tbo].Rows(L).Copy [Tbo].Item(n + nb, 1): [Tbo].Item(n + nb, 5) = A(n - 1)
      Next
    End If
  Next
  [Tbo].Sort [Tbo].Item(1, 5), Header:=1      'tri selon la colonne 5 du tableau avec Item( ,5)
  For Each R In [Tbo[C5]]
   If R Like "*,*" Then [Tbo].Rows(R.Row - [Tbo].Row + 1).Delete  '          'ligne du Tableau (pas de l'onglet !)
  Next
End Sub

* L'outil Tableau (dans une feuille) est très peu souvent utilisé malgré ses multiples avantages d'où cet exemple
(structure, syntaxe simple -pas issue de l'enregistreur de macro …).

**babacoolcool** · 09/11/2018, 17h09

Merci voici le fichier

merci d'avance

**OrDonc** · 09/11/2018, 18h08

re

Voir si cela convient. J'ai notifié les petits changements apportés à mon code (Alt F11 pour les voir).

Invité · 09/11/2018, 18h14

Envoyé par babacoolcool

A tester :

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
 
Option Explicit
 
Sub M100_DupliquerLesLignes()
 
Dim I As Long, LigneEncours As Long, LigneTitre As Long, DerniereLigne As Long, ColIndice As Long, ColRepere As Long
Dim AireATester As Range, CelluleATester As Range
Dim J As Integer, NbRepetitions As Integer
 
    With ActiveSheet
 
         Application.ScreenUpdating = False
 
         LigneTitre = 10
         ColIndice = .Cells(LigneTitre, .Columns.Count).End(xlToLeft).Column + 1
         ColRepere = 6
         DerniereLigne = .Cells(.Rows.Count, ColRepere).End(xlUp).Row
         LigneEncours = DerniereLigne + 1
 
         Set AireATester = .Range(.Cells(LigneTitre + 1, ColRepere), .Cells(DerniereLigne, ColRepere))
 
         I = 1
         .Cells(LigneTitre, ColIndice) = "Indice"
         For Each CelluleATester In AireATester
             CelluleATester.Offset(0, ColIndice - ColRepere) = I
             I = I + 1
         Next CelluleATester
 
         For Each CelluleATester In AireATester
             NbRepetitions = UBound(ListeEntreVirgules(CelluleATester.Value))
             If NbRepetitions > 0 Then
                For J = 1 To NbRepetitions
                    CelluleATester.EntireRow.Copy Destination:=.Cells(LigneEncours, 1)
                    LigneEncours = LigneEncours + 1
                Next J
             End If
         Next CelluleATester
 
         TrierUnTableau ActiveSheet, LigneTitre, ColIndice
 
         DerniereLigne = .Cells(.Rows.Count, ColRepere).End(xlUp).Row
         .Range(.Cells(LigneTitre, ColIndice), .Cells(DerniereLigne, ColIndice)).Clear
 
         Application.ScreenUpdating = True
 
         MsgBox "Fin de la duplication !", vbInformation
 
 
   End With
 
    Set AireATester = Nothing
 
End Sub
 
 
Function ListeEntreVirgules(ByRef ContenuCelluleG As String) As Variant
 
  ListeEntreVirgules = Split(ContenuCelluleG, ",")
 
End Function
 
 
 
 
Sub TrierUnTableau(ByVal FeuilleATrier As Worksheet, ByVal LigneDeTitre As Long, ByVal ColonneATrier As Long)
 
Dim DerniereColonne As Long
Dim DerniereLigne As Long
 
Dim AireATrier As Range
Dim AireColonne As Range
 
    With FeuilleATrier
 
         DerniereColonne = .Cells(LigneDeTitre, .Columns.Count).End(xlToLeft).Column
         DerniereLigne = .Cells(.Rows.Count, ColonneATrier).End(xlUp).Row
 
         If DerniereLigne > LigneDeTitre Then
            Set AireATrier = .Range(.Cells(LigneDeTitre, 1), .Cells(DerniereLigne, DerniereColonne))
            Set AireColonne = .Range(.Cells(LigneDeTitre, ColonneATrier), .Cells(DerniereLigne, ColonneATrier))
 
            .Sort.SortFields.Clear
            .Sort.SortFields.Add Key:=AireColonne, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            With .Sort
                 .SetRange AireATrier
                 .Header = xlYes
                 .MatchCase = False
                 .Orientation = xlTopToBottom
                 .SortMethod = xlPinYin
                 .Apply
             End With
 
             Set AireColonne = Nothing
             Set AireATrier = Nothing
 
          End If
 
    End With
 
End Sub

**babacoolcool** · 13/11/2018, 15h32

Envoyé par OrDonc

re

Voir si cela convient. J'ai notifié les petits changements apportés à mon code (Alt F11 pour les voir).

Super merci c'est tut a fait ça

mais je n'arrive pas a voir la macro, comment faire?

Merci d'avance

Irène

**babacoolcool** · 14/11/2018, 10h33

j’aimerai dupliquer une ligne autant de fois qu'il y a de virgules dans une cellule en laissant qu'une donnée par ligne
Mon tableau fait 180000 lignes!

AVANT:

AUDIOVISUEL

17/04/2018

Mardi 17/04/2018

08:30

18:30

10:00

V_C125, V_C127

TRAVAUX INSTALLATION ET MAINTENANCE

RESULTAT

AUDIOVISUEL	17/04/2018	Mardi 17/04/2018	08:30	18:30	10:00	V_C125	TRAVAUX INSTALLATION ET MAINTENANCE
AUDIOVISUEL	17/04/2018	Mardi 17/04/2018	08:30	18:30	10:00	V_C127	TRAVAUX INSTALLATION ET MAINTENANCE

merci d'avance

Irène toujours en galère

Invité · 14/11/2018, 10h47

Envoyé par babacoolcool

Dans ma solution, modifier la procédure suivante :

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
 
Sub M100_DupliquerLesLignes()
 
Dim I As Long, LigneEncours As Long, LigneTitre As Long, DerniereLigne As Long, ColIndice As Long, ColRepere As Long
Dim AireATester As Range, CelluleATester As Range
Dim J As Integer, NbRepetitions As Integer
 
    With ActiveSheet
 
         Application.ScreenUpdating = False
 
         LigneTitre = 10
         ColIndice = .Cells(LigneTitre, .Columns.Count).End(xlToLeft).Column + 1
         ColRepere = 6
         DerniereLigne = .Cells(.Rows.Count, ColRepere).End(xlUp).Row
         LigneEncours = DerniereLigne + 1
 
         Set AireATester = .Range(.Cells(LigneTitre + 1, ColRepere), .Cells(DerniereLigne, ColRepere))
 
         I = 1
         .Cells(LigneTitre, ColIndice) = "Indice"
         For Each CelluleATester In AireATester
             CelluleATester.Offset(0, ColIndice - ColRepere) = I
             I = I + 1
         Next CelluleATester
 
         For Each CelluleATester In AireATester
             NbRepetitions = UBound(ListeEntreVirgules(CelluleATester.Value))
             If NbRepetitions > 0 Then
                For J = 1 To NbRepetitions
                    CelluleATester.EntireRow.Copy Destination:=.Cells(LigneEncours, 1)
                    .Cells(LigneEncours, CelluleATester.Column) = ListeEntreVirgules(CelluleATester.Value)(J)
                    LigneEncours = LigneEncours + 1
                Next J
             End If
             CelluleATester = ListeEntreVirgules(CelluleATester.Value)(0)
         Next CelluleATester
 
         TrierUnTableau ActiveSheet, LigneTitre, ColIndice
 
         DerniereLigne = .Cells(.Rows.Count, ColRepere).End(xlUp).Row
         .Range(.Cells(LigneTitre, ColIndice), .Cells(DerniereLigne, ColIndice)).Clear
 
         Application.ScreenUpdating = True
 
         MsgBox "Fin de la duplication !", vbInformation
 
 
   End With
 
    Set AireATester = Nothing
 
End Sub

**babacoolcool** · 16/11/2018, 20h03

merci mais ça ne fonctionne pas il copie bien la ligne mais laisse toujours toutes les données après la virgule

Invité · 17/11/2018, 06h03

Envoyé par babacoolcool

Ben non !

**OrDonc** · 23/11/2018, 12h15

Re

Je pense ne pas être le seul à mélanger les discussions traitées donc une autre proposition sachant que la durée de traitement est d'autant plus importante que le nombre de lignes augmente (même avec des tableaux).

Lancement à l'activation de la feuille cible (déjà préparée) et Alt + F11 pour ouvrir la fenêtre des codes

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
Option Explicit
Option Base 1
Dim T, n As Long, A, c As Byte, k As Byte, li As Long, Tb()
Private Sub Worksheet_Activate()
  Application.ScreenUpdating = 0
  Set T = [Tbo]: li = 1
  n = Application.CountIf([Tbo[salles]], "*,*")
  ReDim Tb(n + [Tbo].Rows.Count + 2, 12)
  For n = 1 To [Tbo].Rows.Count
    For c = 1 To 11: Tb(li, c) = T(n, c): Next
    A = Split(T(n, 6), ",")
    If UBound(A) > 0 Then
      For k = 1 To UBound(A)
        Tb(li, 6) = A(0)
        li = li + 1
        For c = 1 To 11: Tb(li, c) = T(n, c): Next
        Tb(li, 6) = LTrim(A(k))
      Next
    End If
    li = li + 1
  Next
  Me.ListObjects("TbS").Resize Range("$A$2:$K$" & li + 1)
  [TbS] = Tb
End Sub
Private Sub Worksheet_Deactivate()                                  'utile pour alléger de classeur
  If [TbS].Item(1, 1) <> "" Then [TbS].Delete
End Sub!

Le fichier joint n'a pas une grande quantité de lignes mais la macro prend quand même quelques secondes.

Dupliquer ligne entière si virgule dans une cellule

Excel

Discussions similaires

Partager

Partager