Страницы: 1
RSS
Создание матрицы из таблицы, Создание матрицы из таблицы
 
Добрый день!

Есть таблица с перечнем должностей, с указанием уровня (грейда) и функции для каждой должности. В оригинале у меня данные по более чем по 1000 уникальных должностей и гораздо большему кол-ву функций.

Необходимо все должности расположить в матрицу, где по вертикали будут грейды, а по столбцам функции.
Во вложении файл с примером таблицы и примером, как это должно выстраиваться в матрицу (на второй вкладке).
Делаю вручную, подскажите, пожалуйста, варианты, как раскладывать подобные вещи в матрицу автоматически?

Особенность в том, что на одном грейде может быть несколько должностей, поэтому строки с грейдами в таком случае должны добавляться.

Буду признательна за помощь.
Из рабочих инструментов Excel 2010.
 
Имхо, решение вашей проблемы: ссылка здесь
 
Код
Sub JobFunction()
    Dim arr As Variant
    arr = GetArr(Columns("A:B"))
    
    Dim xMax As Long
    Dim dic As Object
    Set dic = GetDic(arr, xMax)
    arr = Empty
    If dic.Count = 0 Then Exit Sub
    
    arr = LeaveN(dic, xMax)
    Set dic = Nothing
    
    PrintArr arr
End Sub

Private Sub PrintArr(arr As Variant)
    ActiveSheet.Copy
    ActiveSheet.Cells.ClearContents
    
    With ActiveWorkbook
        With .Sheets(1)
            With .Cells(1, 1).Resize(UBound(arr, 1), UBound(arr, 2))
                .Value = arr
            End With
        End With
    End With
End Sub

Private Function LeaveN(dic As Object, xMax As Long) As Variant
    Dim arr As Variant
    ReDim arr(1 To dic.Count, 1 To 1 + xMax)
    Dim bic As Object
    
    Dim ni As Long
    Dim yd As Long
    Dim ya As Long
    Dim vKey As Variant
    For Each vKey In dic.Keys
        Set bic = dic.Item(vKey)
        ya = ya + 1
        arr(ya, 1) = vKey
        For ni = 1 To bic.Count
            arr(ya, 1 + ni) = bic.Keys()(ni - 1)
        Next
    Next
    
    LeaveN = arr
End Function

Private Function GetDic(arr As Variant, xMax As Long) As Object
    Dim dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    
    Dim ya As Long
    For ya = 1 To UBound(arr, 1)
        If Not dic.Exists(arr(ya, 1)) Then
            Set dic.Item(arr(ya, 1)) = CreateObject("Scripting.Dictionary")
        End If
    Next
    
    For ya = 1 To UBound(arr, 1)
        dic.Item(arr(ya, 1)).Item(arr(ya, 2)) = 0
        If xMax < dic.Item(arr(ya, 1)).Count Then xMax = dic.Item(arr(ya, 1)).Count
    Next
    
    Set GetDic = dic
End Function

Private Function GetArr(rr As Range) As Variant
    GetArr = Intersect(rr, rr.Parent.UsedRange).Value
End Function
Вчера как-раз была очень похожая задача.
Выбор первых 10 строк (planetaexcel.ru)
 
R091n,

Спасибо за наводку!
Получилось решить задачу через Power Query
 
musik0711, в PQ можно так (только в первой строке в Item="Исходник" поставьте правильное название листа):
Код
let
    fr = Excel.Workbook(File.Contents("C:\ путь к вашему файлу .xlsx"),true){[Kind = "Sheet", Item="Исходник"]}[Data],
    f = (x)=> Record.FromList({x{0}},{x{1}})&[Функция = x{2}],
    a1 = List.Transform(Table.ToRows(fr),f),
    a2 = Table.Sort(Table.FromRecords(a1, {"Функция"}&List.Distinct(fr[Функция]), MissingField.UseNull), {"Функция", Order.Descending})
in
    a2
Изменено: Garrys - 29.11.2023 13:17:57
Страницы: 1
Наверх