Sub Расставить_числа()

    Dim shSrc As Worksheet, arrSrc(), shRes As Worksheet
    Dim var, lr As Long, lc As Long, rRes As Long, cRes As Long
    Dim i As Long, j As Long
    
    Application.ScreenUpdating = False
    
    Set shSrc = Worksheets("Лист1")
    Set shRes = Worksheets("Лист2")
    
    lr = shRes.Cells.Find(What:="*", LookIn:=xlFormulas, LookAt:= _
        xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False _
        , SearchFormat:=False).Row
    If lr > 2 Then
        shRes.Rows("2:" & lr).ClearContents
    End If
    
    lr = shSrc.Cells.Find(What:="*", LookIn:=xlFormulas, LookAt:= _
        xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False _
        , SearchFormat:=False).Row
    lc = shSrc.Cells(1, shSrc.Columns.Count).End(xlToLeft).Column
    arrSrc() = shSrc.Range("A1").Resize(lr, lc).Value
    
    lc = shRes.Cells(1, shRes.Columns.Count).End(xlToLeft).Column
    For cRes = 1 To lc
        rRes = 1
        var = shRes.Cells(1, cRes).Value
        For i = 1 To UBound(arrSrc, 1) Step 2
            For j = 1 To UBound(arrSrc, 2)
                If arrSrc(i, j) = var Then
                    rRes = rRes + 1
                    shRes.Cells(rRes, cRes).Value = arrSrc(i + 1, j)
                End If
            Next j
        Next i
    Next cRes
    
    Application.ScreenUpdating = True
    MsgBox "Готово!", vbInformation

End Sub