Option Explicit
Sub jjj() ' _
http://planetaexcel.ru/forum/index.php?PAGE_NAME=message&FID=1&TID=71005&TITLE_SEO=71005-perenos-dannykh-v-tablichnyy-vid-s-pomoshchyu-makrosa&MID=595048#message595048

Dim rngData As Range, rngDate As Range, rng As Range, cls As Range, cl As Range, rngOut As Range, dict As Object, _
lColumn%, i_Columns%
    
    Application.ScreenUpdating = False
    Set rngData = Cells(1, 1).End(xlDown)
    If rngData Is Nothing Then Exit Sub
    Set rngData = Range("A2:K" & rngData.Row)
    i_Columns = rngData.Columns.Count
    Set rngDate = Rows(1)
    lColumn = Cells(1, 1).End(xlToRight).Column
    Set dict = CreateObject("scripting.dictionary")
    Set rngOut = ThisWorkbook.Worksheets("как нужно").Range("A2")
    For Each rng In rngData.Rows
        On Error Resume Next
        Set cls = Range(Cells(rng.Row, 12), Cells(rng.Row, lColumn)).SpecialCells(xlCellTypeConstants)
        On Error GoTo 0
        If Not cls Is Nothing Then
            For Each cl In cls
                dict(rngDate.Cells(cl.Column).Value) = cl.Value
            Next cl
            rng.Copy rngOut.Resize(dict.Count, i_Columns)
            rngOut.Offset(, i_Columns).Resize(dict.Count).Value = _
                WorksheetFunction.Transpose(dict.keys)
            rngOut.Offset(, i_Columns + 1).Resize(dict.Count).Value = _
                WorksheetFunction.Transpose(dict.items)
            Set rngOut = rngOut.Offset(dict.Count)
            dict.RemoveAll
        End If
    Next rng
End Sub