Discussion :

[steelk]

Bonjour,

Je souhaiterais effectuer un découpage de cellule comprenant des zones de textes avec retour chariot, par exemple à partir de ceci:
Le tableau est volontairement simplifié en nombre de colonne

Produit	Reference composant	Composant	Quantité	Garantie
Carte electronique	Ref A Ref B Ref C	Voyant Condensateur Transistor	1 3 2	OUI
Clavier	Ref D Ref A Ref E	Touche Voyant Roulette	36 5 1	NON

Je voudrais ceci:

Produit	Reference composant	Composant	Quantité	Garantie
Carte electronique	Ref A	Voyant	1	OUI
Carte electronique	Ref B	Condensateur	3	OUI
Carte electronique	Ref C	Transistor	2	OUI
Clavier	Ref D	Touche	36	NON
Clavier	Ref A	Voyant	5	NON
Clavier	Ref E	Roulette	1	NON

Ce qui conditionne le découpage est le nombre de lignes de reference composant (Ref ...)

En vous remerciant par avance de vos aides a tous,

[Marc-L]

Bonjour et félicitations pour cette présentation !

Supposant que tu t'y connais quelque peu en VBA, je suggère de jeter un œil à la propriété CurrentRegion et à la fonction Split.

[Invité]

Bonjour,
pour compléter ce qu'a diit Marc, j'ajouterai la méthode transpose.

Mais je ne m'en souviens pas mais je pense qu'il y a une métode qui le fait directe Marc tu t'en rappel?

[Kimy_Ire]

Bonjour steelk,

Je te propose la macro ci-dessous susceptible de répondre à 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
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
Option Explicit
 
Sub steelk()
Dim rng As Range
Dim i As Integer, j As Integer, k As Integer
Dim elmt() As String
 
With Worksheets("Découpage")
    Set rng = .Cells.Find("Produit", LookIn:=xlValues, LookAt:=xlWhole).Offset(0, 1)
    i = 1
 
    Do While rng.Offset(i, 0) <> ""
        If InStr(rng.Offset(i, 0), vbLf) Then
            elmt = Split(rng.Offset(i, 0), vbLf)
            For j = LBound(elmt) To UBound(elmt) - 1
                rng.Offset(i + 1, 0).EntireRow.Insert Shift:=xlDown
                rng.Offset(i + 1, -1) = rng.Offset(i, -1)
                rng.Offset(i + 1, 3) = rng.Offset(i, 3)
            Next j
 
            For k = 0 To 2
                elmt = Split(rng.Offset(i, k), vbLf)
                For j = LBound(elmt) To UBound(elmt)
                    rng.Offset(i + j, k) = elmt(j)
                Next j
            Next k
 
        End If
        i = i + 1
    Loop
End With
 
End Sub

Elle est très spécifique et peut poser plusieurs soucis :

1. Je me base sur la cellule contenant "Produit" pour rechercher la localisation de ton tableau. En d'autres termes, si tu as plusieurs cellule de la sorte, cela risque d'être problématique.
2. Pour parcourir ton tableau, je considère que tu n'as pas de blanc dans ta colonne "Référence composant". Si c'est le cas, la macro s'arrêtera à cette cellule.

@Marc-L : "Split", c'est la vie !!!
@rdurupt : J'avoue ne pas visualiser comment utiliser la méthode "Transpose" pour ce cas de figure. Et finalement... il y a surement une méthode qui fait toute seule ce que j'ai fait !

Enfin, ma macro n'est pas optimisée. Il y a beaucoup mieux à faire...
Quoi qu'il en soit, j'espère qu'elle répondra à ton besoin.

N'hésite pas à revenir vers moi pour tout complément !

Cordialement,
Kimy

[Marc-L]

Robert, cela ne me dit rien … Je verrai un TextToColums puis un Transpose mais
j'ai pris pour habitude (mauvaise ?) d'utiliser une variable tableau puis une boucle combinée à Split …

[Invité]

Bonjour,,

@rdurupt : J'avoue ne pas visualiser comment utiliser la méthode "Transpose" pour ce cas de figure. Et finalement... il y a surement une méthode qui fait toute seule ce que j'ai fait !
N'hésite pas à revenir vers moi pour tout complément !
Cordialement,
Kimy

Code :

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

1
2
3
4
5
6
7
8
9
10
11
12
13
Sub Test()
Dim R As Range
Dim L As Long
Dim Spl
Set R = ActiveSheet.UsedRange
For L = R.Rows.Count To 1 Step -1
    Spl = Split(R(L, 1), Chr(10))
    If UBound(Spl) > -1 Then
    R.Range(R(L + 1, 1), R(L + 1, 1).Offset(UBound(Spl) - 1)).EntireRow.Insert
    R.Range(R(L, 1), R(L, 1).Offset(UBound(Spl))) =Application.Transpose(Spl)
    End If
Next
End Sub

[Marc-L]

Michael, ton code a déjà le mérite de répondre au besoin !

Pour chipoter, dans le cas de centaines de lignes à traiter,
il vaudrait mieux désactiver l'affichage afin d'accélérer la procédure …

Je ne suis pas sûr si l'insertion est la méthode la plus rapide
mais elle a l'avantage de conserver le format des cellules.

Voici une autre voie - via des variables tableau - comportant des sécurités;
même si le nombre de lignes de code est plus conséquent, elle semble toutefois assez véloce …

Traitement principal dans le bloc des lignes n°16 à 35.
Le bloc suivant est optionnel, il sert juste à uniformiser le format des lignes …

Code à copier dans le module de la feuille à traiter :

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
Sub Demo()
     Dim Rg As Range
     Set Rg = Me.UsedRange.Find("Produit", , xlValues, xlWhole, xlByRows)
      If Rg Is Nothing Then Beep: End
 
    With Rg.CurrentRegion
        CC& = .Columns.Count:  RC& = .Rows.Count
 
        If CC < 4 Or RC = 1 Or .Columns(2).Find(vbLf, , xlValues, xlPart) Is Nothing Then _
            Set Rg = Nothing: Beep: End
 
        VA = .Value:  L& = .Row:  C1& = .Column:  Application.ScreenUpdating = False
                 .HorizontalAlignment = xlCenter:         .VerticalAlignment = xlCenter
    End With
                                ReDim SP(2 To 4):  SP(3) = Split(""):  SP(4) = SP(3)
    For R& = 2 To RC
        For C& = 2 To 4
            SP(C) = Split(VA(R, C), vbLf)
            If C = 2 Then U& = UBound(SP(2)): If U = 0 Then Exit For
        Next
 
        If U And UBound(SP(3)) = U And UBound(SP(4)) = U Then
            ReDim AR(0 To U, 1 To CC)
 
            For N& = 0 To U
                For C = 1 To CC
                    If C < 2 Or C > 4 Then AR(N, C) = VA(R, C) Else AR(N, C) = SP(C)(N)
                Next
            Next
 
               Cells(L + 1, C1).Resize(U + 1, CC).Value = AR:  L = L + U + 1
        Else
            L = L + 1:  Cells(L, C1).Resize(, CC).Value = Application.Index(VA, R)
        End If
    Next
 
    With Rg.CurrentRegion
        If .Rows.Count > RC Then
           .Rows(RC).Copy:  Me.Activate:  AD$ = ActiveCell.Address
           .Rows(RC + 1 & ":" & .Rows.Count).PasteSpecial xlPasteFormats
            Application.CutCopyMode = False:  Range(AD).Select
        End If
    End With
 
    Set Rg = Nothing:  Erase AR, SP, VA
End Sub

_________________________________________________________________________________________________

Merci de cliquer sur pour chaque message ayant aidé puis sur pour clore cette discussion …

_________________________________________________________________________________________________
On ne dit pas une biroute mais une route à deux voies …

[Invité]

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
Sub Test()
Dim R As Range
Dim L As Long
Dim Spl2, Spl3, Spl4
Dim Nb As Integer
Set R = ActiveSheet.UsedRange
For L = R.Rows.Count To 2 Step -1
Nb = -1
    Spl2 = Split(R(L, 2), Chr(10))
    Spl3 = Split(R(L, 3), Chr(10))
    Spl4 = Split(R(L, 4), Chr(10))
    If UBound(Spl2) > Nb Then Nb = UBound(Spl2)
    If UBound(Spl3) > Nb Then Nb = UBound(Spl3)
    If UBound(Spl4) > Nb Then Nb = UBound(Spl4)
    If Nb > 0 Then
    R.Range(R(L + 1, 1), R(L + 1, 1).Offset(Nb - 1)).EntireRow.Insert
    If UBound(Spl2) > -1 Then R.Range(R(L, 2), R(L, 2).Offset(UBound(Spl2))) = Application.Transpose(Spl2)
    If UBound(Spl3) > -1 Then R.Range(R(L, 3), R(L, 3).Offset(UBound(Spl3))) = Application.Transpose(Spl3)
    If UBound(Spl4) > -1 Then R.Range(R(L, 4), R(L, 4).Offset(UBound(Spl4))) = Application.Transpose(Spl4)
     R.Range(R(L, 1), R(L, 1).Offset(Nb)) = R(L, 1)
     R.Range(R(L, 5), R(L, 5).Offset(Nb)) = R(L, 5)
       MiseEnPage R.Range(R(L, 1), R(L, 5).Offset(Nb))
 
    End If
Next
End Sub
Sub MiseEnPage(R As Range)
 With R.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Color = -6710887
        .TintAndShade = 0
        .Weight = xlThick
    End With
    With R.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Color = -6710887
        .TintAndShade = 0
        .Weight = xlThick
    End With
      With R.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Color = -6710887
        .TintAndShade = 0
        .Weight = xlThick
    End With
      With R.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Color = -6710887
        .TintAndShade = 0
        .Weight = xlThick
    End With
     With R.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .Color = -6710887
        .TintAndShade = 0
        .Weight = xlThick
    End With
      With R.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .Color = -6710887
        .TintAndShade = 0
        .Weight = xlThick
    End With
End Sub