Нормализация данных в таблице

Private Sub Test2()
    Dim ws As Worksheet, r As Range
    Set ws = Worksheets("Исходник")
    Dim txt$, a1, a2, a3, rw&: rw = 6 'Номер первой строки
    Dim rw1&, rw2&, rwMax&, clMax&, cl&, cPlan&, clPlan&
    
    Set r = ws.Range("B4").CurrentRegion
    a1 = r.Value: a3 = ws.Range("C1:C3").Value
    rwMax = UBound(a1) - 1: clMax = UBound(a1, 2)    
    cPlan = (clMax - 6) / 2
    ReDim a2(1 To (rwMax - rw) * cPlan, 1 To 13)
 
    For clPlan = 1 To cPlan
        For rw1 = rw To rwMax
            If Not IsEmpty(a1(rw1, 1)) Then
               rw2 = rw2 + 1: a2(rw2, 1) = txt
               For cl = 2 To 7
                   a2(rw2, cl) = a1(rw1, cl - 1)
               Next
               a2(rw2, cl) = a1(4, 5 + clPlan * 2)
               a2(rw2, cl + 1) = a1(rw1, 5 + clPlan * 2)
               a2(rw2, cl + 2) = a1(rw1, 6 + clPlan * 2)
               For cl = 1 To 3
                   a2(rw2, cl + 10) = a3(cl, 1)
               Next
            Else: txt = a1(rw1, 2): End If
        Next
    Next
    With Worksheets.Add.Cells(1).Resize(rw2, 13)
         .Value = a2: .Columns.AutoFit
         .Borders.LineStyle = xlContinuous
    End With
End Sub

    With Worksheets.Add
         .Cells(2, 1).Resize(rw2, 13).Value = a2
         With .Cells(1, 1).Resize(, 13) '.Range("A1:M1")
              .Font.Bold = True
              .Interior.ColorIndex = 35
              '.Value = Array("Группа", "№", "Цель", "Критерий", "Вид", "Оценка", "Ед. измерения", "Период", "Вес", "План", "ФИО", "Должность", "Подразделение")
              .Value = Split("Группа,№,Цель,Критерий,Вид,Оценка,Ед. измерения,Период,Вес,План,ФИО,Должность,Подразделение", ",")
         End With
         With .UsedRange
              .Columns.AutoFit
              .Borders.LineStyle = xlContinuous
         End With
    End With