Transposition (tableau -> BDD) avec cellules comprenant plusieurs heures

[zebanx]

Bonsoir à tous,

J'ai eu le privilège de bénéficier de nombreuses réponses sur les transpositions (liste non exhaustive : mapomme, klin89, pierre-jean...) dont je remercie encore les auteurs ...
mais pas certain d'avoir vu une transposition de données comme celle présentée sur le tableau suivant, c'est à dire avec des cellules de données comprenant plusieurs valeurs.

Est-il facile de transposer avec ce "montage" SVP ?

Vous remerciant par avance pour vos commentaires / réponses, bonne soirée,
zebanx

Pour info, je me permets de fournir un code de Klin89 pour une transposition d'un tableau à double entrée "simple" (1 ligne en haut, 1 colonne à gauche et toutes les données du tableau).

Sub sh03_transpose()
'fait par klin89
Dim a, i As Long, j As Long, b(), n As Long
    a = Sheets("sh03_brut").Range("b2").CurrentRegion.Value
    ReDim b(1 To UBound(a, 1) * UBound(a, 2), 1 To 3)
    For j = 2 To UBound(a, 2)
        For i = 2 To UBound(a, 1)
            If Not IsEmpty(a(i, j)) Then
                n = n + 1
                b(n, 1) = a(1, j)
                b(n, 2) = a(i, 1)
                b(n, 3) = a(i, j)
            End If
        Next
    Next
    'Restitution
    With Sheets("sh03_res").Cells(1).Resize(n, 3)
        .CurrentRegion.ClearContents
        .Value = b
    End With
End Sub

 

[klin89]

Bonsoir zebanx,

Un truc de ce genre :

Option Explicit
Sub test()
Dim a, b(), x, i As Long, ii As Byte, iii As Byte, n As Long
    a = Sheets("tablo").Range("a1").CurrentRegion.Value
    'attention a la 1ere dimension
    ReDim b(1 To 100, 1 To 3)
    For i = 2 To UBound(a, 2)
        For ii = 2 To UBound(a, 1)
            x = Split(a(ii, i), ",")
            For iii = 0 To UBound(x)
                n = n + 1
                b(n, 1) = a(ii, 1)
                b(n, 2) = a(1, i)
                b(n, 3) = x(iii)
            Next
        Next
    Next
    With Sheets.Add().Cells(1).Resize(n, 3)
        .Value = b
        .Columns.AutoFit
    End With
End Sub

Y'a un problème, faut convertir tes données
Pas trop le temps en ce moment.

klin89

 

[zebanx]

Superbe Klin89


Et j'ai juste légèrement modifié le code pour le placer dans une feuille BDD2 en insérant un trim sur les données.
Ca à l'air de fonctionner de cette manière. Merci beaucoup !

Bonne soirée à toi
zebanx

Sub test()
Dim a, b(), x, i As Long, ii As Byte, iii As Byte, n As Long
    a = Sheets("tablo").Range("a1").CurrentRegion.Value
    'attention a la 1ere dimension
    ReDim b(1 To 100, 1 To 3)
    For i = 2 To UBound(a, 2)
        For ii = 2 To UBound(a, 1)
            x = Split(a(ii, i), ",")
            For iii = 0 To UBound(x)
                n = n + 1
                b(n, 1) = a(ii, 1)
                b(n, 2) = a(1, i)
                b(n, 3) = Trim(x(iii))
            Next
        Next
    Next
    'With Sheets.Add().Cells(1).Resize(n, 3)
     With Sheets("bdd2").Cells(1).Resize(n, 3)
        .Value = b
        .Columns.AutoFit
     End With
    With Sheets("bdd2").Columns(3)
        .NumberFormat = "[hh]:mm"
    End With
  
End Sub

 

[klin89]

Re zebanx,

Plutôt comme ceci :

Option Explicit
Sub test()
Dim a, b(), x, i As Byte, ii As Long, iii As Byte, n As Long
    a = Sheets("tablo").Range("a1").CurrentRegion.Value
    'attention a la 1ere dimension
    ReDim b(1 To 100, 1 To 3)
    For i = 2 To UBound(a, 2)
        For ii = 2 To UBound(a, 1)
            If IsNumeric(a(ii, i)) Then
                n = n + 1
                b(n, 1) = a(ii, 1)
                b(n, 2) = a(1, i)
                b(n, 3) = a(ii, i)
            Else
                x = Split(a(ii, i), ",")
                For iii = 0 To UBound(x)
                    n = n + 1
                    b(n, 1) = a(ii, 1)
                    b(n, 2) = a(1, i)
                    b(n, 3) = x(iii)
                Next
            End If
        Next
    Next
    With Sheets.Add().Cells(1).Resize(n, 3)
        .Value = b
        .Columns(3).NumberFormat = "[hh]:mm"
        With .Font
            .Name = "calibri"
            .Size = 10
        End With
        .VerticalAlignment = xlCenter
        .Borders(xlInsideVertical).Weight = xlThin
        .BorderAround Weight:=xlThin
    End With
End Sub

klin89

 

[zebanx]

Ok Klin89

Je regarderai ça demain plus attentivement...

Bonne nuit