Private Sub Workbook_SheetBeforeDoubleClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)
    Application.ScreenUpdating = False
    Cancel = True 'отмена* даблклика
    a = ActiveSheet.Name 'имя активного листа
    b = Cells(Rows.Count, "a").End(xlUp).Row 'нижнаяя строка таблицы (столбец A)
    If b > 3 Then '1-я фио должна быть в 4 строке, только тогда преобразуем
        d = 3       '1-й столбец января
        e = 9       'кол-во столбцом в месяце
        k = 3       'кол-во строк в шапке*
        'создадим лист результата
        Sheets.Add After:=Sheets(Sheets.Count)
        f = Sheets(Sheets.Count).Name 'имя листа результата
        'пройдемся циклом по фио
        For g = k + 1 To b 'g - строка с очередной фамилией
            'фио-остаток
            m = Sheets(f).Cells(Rows.Count, "c").End(xlUp).Row + 1
            Sheets(a).Range("a1:b3").Copy Sheets(f).Range("a" & m)
            Sheets(a).Range("a" & g & ":b" & g).Copy Sheets(f).Range("a" & m + k)
            'пройдемся циклом по месяцам
            For h = 1 To 12
                i = (h - 1) * e + d 'левый столбец месяца
                j = h * e + d - 1   'правый столбец месяца
                l = Sheets(f).Cells(Rows.Count, "c").End(xlUp).Row + 1 'строка вставки
                'копируем-втавляем шапку
                Sheets(a).Range(Sheets(a).Cells(1, i), Sheets(a).Cells(k, j)).Copy Sheets(f).Range("c" & l)
                'копируем-втавляем данные
                Sheets(a).Range(Sheets(a).Cells(g, i), Sheets(a).Cells(g, j)).Copy Sheets(f).Range("c" & l + k)
            Next
            'объединим и установим границы
            n = Sheets(f).Cells(Rows.Count, "c").End(xlUp).Row
            With Sheets(f).Range("a" & m + k & ":a" & n)
                .Merge
                .Borders(xlEdgeLeft).LineStyle = xlContinuous
                .Borders(xlEdgeRight).LineStyle = xlContinuous
                .Borders(xlEdgeBottom).LineStyle = xlContinuous
            End With
            Sheets(f).Range("b" & n).Borders(xlEdgeBottom).LineStyle = xlContinuous
        Next
    End If
    Application.ScreenUpdating = True
End Sub