Excel rozložení tabulky

[dikobraz]

Ahoj, měl bych na vás zkušenější dotaz. V příloze je ukázka tabulky, se kterou pravidelně pracuji, ale vstupní rozložení je špatné a zatím se mi nedaří přijít na způsob, jak to snadno upravit do potřebného tvaru, který je na druhém listu v souboru.
Napadlo by někoho nějaké efektivní řešení?
Moc děkuji všem za pomoc.

[Reklama]

[elninoslov]

Môže byť makro?

Kód: Vybrat vše

Sub prevod_dat()
Dim D(), V(), R As Long, Poz As Long, rngBold As Range, rngItalic As Range

    D = Worksheets("takhle to dostanu").UsedRange.Value
    ReDim V(1 To UBound(D, 1), 1 To 5)
   
    With Worksheets("makro")
        For R = 1 To UBound(D, 1)
            If IsEmpty(D(R, 4)) Then
                Poz = R
            Else
                If Not IsEmpty(D(R, 1)) Then
                    V(R, 1) = D(Poz, 1)
                    V(R, 2) = D(R, 1)
                    If rngBold Is Nothing Then Set rngBold = .Cells(R, 1) Else Set rngBold = Union(rngBold, .Cells(R, 1))
                Else
                    Set rngBold = Union(rngBold, .Cells(R, 5))
                    If rngItalic Is Nothing Then Set rngItalic = .Cells(R, 5) Else Set rngItalic = Union(rngItalic, .Cells(R, 5))
                End If
                V(R, 5) = D(R, 4)
            End If
        Next R
   
        .UsedRange.Clear
        .Cells(1, 1).Resize(UBound(V, 1), 5).Value = V
        rngBold.Font.Bold = True
        rngItalic.Font.Italic = True
        With .Cells(1, 1).Resize(UBound(V, 1), 5)
            .Font.Name = "Verdana"
            .Font.Size = 8
            .Columns(5).NumberFormat = "#,##0.00"
        End With
    End With
End Sub

Edit:
Prípadne aj PQ dotaz v prílohe.