[RESOLU] - Re-Construction table de données en fonction de valeurs multiples

[Akortys]

Bonjour à tout le monde,

Bon le titre n'est pas très compréhensible même pour moi.

Code en vba :

J'ai une table de données (feuille Donnees) dans laquelle j'ai des données avec des valeurs multiples (colonne "Commentaires").
Je souhaite grâce à une macro reconstruire cette table de donner en différenciant chaque valeur de la colonne commentaire pour obtenir le résultat de la feuille ("Restitution").
Copie la ligne contenant une valeur multiple séparée par un ";".

Je mets en PJ un fichier qui sera tellement plus parlant que mon charabia.

En vous remerciant d'avance.

 

[Akortys]

Re : Re-Construction table de données en fonction de valeurs multiples

Bonjour,

Pour info j'ai fait le code suivant et cela à l'air de fonctionner donc si cela peut aider qlq'un :

Dim derlgn As Long, derlgn2 As Long

Dim tabSplit As Variant
Dim X As Long, L As Long, Y As Long, S As Long
Dim Ws1 As Worksheet, Ws2 As Worksheet
Set Ws1 = Worksheets("Donnees")
Set Ws2 = Worksheets("Restitution")

With Ws1
derlgn = .Range("A65536").End(xlUp).Row
tabtemp = .Range("A1:AK" & derlgn).Value
End With

With Ws2
.Columns.Delete
derlgn2 = Ws2.Range("A65536").End(xlUp).Row + 1
For L = 1 To UBound(tabtemp, 1)

tabSplit = Split(tabtemp(L, 4), ";")
For Y = 0 To UBound(tabSplit)
For X = 1 To 4 'UBound(tabSplit)
If X = 4 Then
.Cells(derlgn2, X) = tabSplit(Y)
Else
.Cells(derlgn2, X) = tabtemp(L, X)

End If
Next
derlgn2 = Ws2.Range("A65536").End(xlUp).Row + 1
Next
Next
End With
Restitution.Rows(1).Delete

Au plaisir

 

[Efgé]

Re : [RESOLU] - Re-Construction table de données en fonction de valeurs multiples

Bonjour Akortys

Une proposition
(A noter que la première boucle n'est là que pour évitzer un transpose en fin de code)

Private Sub CommandButton1_Click()
Dim i&, J&, K&, L&, x&
Dim TData As Variant, TReport As Variant

With Sheets("Donnees")
    TData = .Range(.Cells(2, 1), .Cells(.Cells(.Rows.Count, 1).End(3).Row, 4))
End With

For i = LBound(TData, 1) To UBound(TData, 1)
    TData(i, 4) = Split(TData(i, 4), ";")
    x = x + 1 + UBound(TData(i, 4))
Next i

ReDim TReport(1 To x, 1 To 4)

For i = LBound(TData, 1) To UBound(TData, 1)
    For L = LBound(TData(i, 4)) To UBound(TData(i, 4))
        J = J + 1
        For K = LBound(TData, 2) To UBound(TData, 2) - 1
            TReport(J, K) = TData(i, K)
        Next K
        TReport(J, 4) = TData(i, 4)(L)
    Next L
Next i

With Sheets("Restitution")
    .Cells(2, 1).Resize(UBound(TReport, 1), UBound(TReport, 2)) = TReport
    .Columns.AutoFit
    .Activate
End With

    
End Sub

Cordialement