[RESOLU] Creer autant de lignes que d'information d'un tableau

[Scoty]

Bonjour le forum, à tous,

Soit un premier que j'ai qui comporte l'effectif du personnel et son métier.

Je souhaite creer sur un autre tableau, autant de ligne que l'effectif donné par métier.

Un deuxieme temps serait d'avoir ce tableau par colonne. Mais je sais qu'un copier/coller transposer me permet de l'avoir en passant par mon premier tableau, d'ou le fait de savoir s'il est possible de l'avoir directement.

PS: je suis tombé sur des cas plus ou moins comme le mien sans trouver exactement ma soluce. Mille excuses si cela a déjà été traité.

Merci d'avance.
@+ Scoty

 

[Efgé]

Re : Creer autant de lignes que d'information d'un tableau

Bonjour Scoty

Si ton effectif est de moins de 65535 , une proposition

Sub test()
Dim i&, J&, K&, D As Object, T As Variant

Set D = CreateObject("scripting.dictionary")

With Sheets("Feuil1")
    T = .Range(.Cells(6, 2), .Cells(.Rows.Count, 2).End(3)(1, 3))
End With
For i = LBound(T, 1) To UBound(T, 1)
    For J = 1 To T(i, 3)
        K = K + 1
        D(K) = Array(T(i, 1), T(i, 2))
    Next J
Next i

Sheets("Feuil2").Cells(2, 1).Resize(D.Count, 2) = Application.Index(D.Items, , 0)
Sheets("Feuil3").Cells(2, 1).Resize(2, D.Count) = Application.Transpose(Application.Index(D.Items, , 0))
    
End Sub

Cordialement

 

[Efgé]

Re : Creer autant de lignes que d'information d'un tableau

Re
Sans limitation:

Sub test()
Dim i&, J&, K&, MAX&
Dim T As Variant, TReport As Variant, TreportTranspose As Variant

With Sheets("Feuil1")
    T = .Range(.Cells(6, 2), .Cells(.Rows.Count, 2).End(3)(1, 3))
    MAX = WorksheetFunction.Sum(.Range(.Cells(6, 4).Address & ":" & .Cells(.Rows.Count, 2).End(3)(1, 3).Address))
End With

ReDim TReport(1 To MAX, 1 To 2)
ReDim TreportTranspose(1 To 2, 1 To MAX)

For i = LBound(T, 1) To UBound(T, 1)
    For J = 1 To T(i, 3)
        K = K + 1
        TreportTranspose(1, K) = T(i, 1)
        TreportTranspose(2, K) = T(i, 2)
        TReport(K, 1) = T(i, 1)
        TReport(K, 2) = T(i, 2)
    Next J
Next i

Sheets("Feuil2").Cells(2, 1).Resize(MAX, 2) = TReport
Sheets("Feuil3").Cells(2, 1).Resize(2, MAX) = TreportTranspose
    
End Sub

Cortdialement

 

[Scoty]

Re : Creer autant de lignes que d'information d'un tableau

Bonjour Efgé,

Impeccable. Mille merci. Bonne journée

@+
Scoty