Pasted

Option Explicit ' http://www.eileenslounge.com/viewtopic.php?f=30&t=31362&p=242769#p242769
Sub Test()
    Dim wsSalary    As Worksheet
    Dim wsTB        As Worksheet
    Dim a           As Variant
    Dim b           As Variant
    Dim aFT         As Variant
    Dim aSD         As Variant
    Dim x           As Double
    Dim m           As Long
    Dim i           As Long
    Dim j           As Long
    Dim n           As Long
    Dim c           As Long
    Dim r           As Long
    Dim d           As Long
        Set wsSalary = ThisWorkbook.Worksheets("Salary")
        Set wsTB = ThisWorkbook.Worksheets("TB")
        With wsTB.Range("A6:AI10000")
            .ClearContents: .Borders.Value = 0: .Cells.UnMerge: .Interior.Color = xlNone
        End With
        m = wsSalary.Cells(Rows.Count, 1).End(xlUp).Row - 2
        If m = 1 Then Exit Sub
        a = wsSalary.Range("A2:CM" & m).Value
        ReDim b(1 To 2 * (UBound(a, 1) + 3 * Application.RoundUp(UBound(a, 1) / 15, 0)), 1 To 35)
 
        aFT = Array(1, 16, 17, 18, 19, 20, 21, 22, , 38, 39, 41, 40, 42, 43, 45, 44, 29, 30, 34, 32, 33, 35, 48, 49, 50, 51, , 54, 53, 55, 91, 2, 8, 14)
        aSD = Array(, 56, 57, 58, 60, 61, , 63, 64, 66, , 59, 64, 65, 67, 70, 68, 69, 71, 79, 78, 81, 82, 83, 74, 85, 86, 87, 90)
 
        For i = LBound(a, 1) To UBound(a, 1)
            n = n + 1
            For j = 1 To UBound(b, 2)
                If Not IsMissing(aFT(j - 1)) Then b(n, j) = a(i, aFT(j - 1))
            Next j
            b(n, 9) = Val(a(i, 26)) + Val(a(i, 27))
            b(n, 28) = Val(a(i, 49)) + Val(a(i, 50)) + Val(a(i, 51))
 
            n = n + 1
            For j = 1 To UBound(b, 2)
                If j = 30 Then Exit For
                If Not IsMissing(aSD(j - 1)) Then b(n, j) = a(i, aSD(j - 1))
            Next j
            b(n, 7) = Val(b(n, 2)) + Val(b(n, 3)) + Val(b(n, 4)) + Val(b(n, 5)) + Val(b(n, 6))
            b(n, 11) = Val(b(n, 8)) + Val(b(n, 9)) + Val(b(n, 10))
        Next i
 
        wsTB.Range("A6").Resize(UBound(b, 1), UBound(b, 2)).Value = b
Rem 2 Insert 3 empty rows
Dim NxtRw As Range ' The next data row
 Set NxtRw = wsTB.Range("B6")
    Do While NxtRw.Value <> "" ' Keep going while the next data row is not empty
     wsTB.Rows("" & NxtRw.Row + 30 & ":" & NxtRw.Row + 32 & "").Insert Shift:=xlDown
     Set NxtRw = wsTB.Range("B" & NxtRw.Row + 33 & "")
    Loop '  While NxtRw.Value <> ""
Rem 3 Get an array of row indicies to identify the first and last rows of data sections
Dim Lr As Long: Let Lr = wsTB.Range("B" & Rows.Count & "").End(xlUp).Row
Dim Cnt As Long
Dim strHindiSees As String: Let strHindiSees = "6 " ' Assume the first row indicie is 6
Dim NextHindiSee As Long: Let NextHindiSee = 6
    For Cnt = 1 To 100000
     Let NextHindiSee = NextHindiSee + 29 ' The next indicie will be 29 rows down
        If NextHindiSee >= Lr Then ' This is to check if we are at or over the final data row
         Let NextHindiSee = Lr
         Let strHindiSees = strHindiSees & NextHindiSee & " " ' add indicie for last data row in current data section
         Exit For
        Else
         Let strHindiSees = strHindiSees & NextHindiSee & " " ' add indicie for last data row in current data section
         Let NextHindiSee = NextHindiSee + 4 ' The next row indicie for the start of next data section
         Let strHindiSees = strHindiSees & NextHindiSee & " " ' add indicie for first data row in next data section
        End If
    Next Cnt
 Let strHindiSees = Mid(strHindiSees, 1, Len(strHindiSees) - 1) ' Take off last space
Dim arrHindiSees() As String ' Split below, returns string type elements
 Let arrHindiSees() = Split(strHindiSees, " ", -1, vbBinaryCompare) ' Split returns a 1 dimensional array of the split up strHindiSees using a " " as the seperator: It chops strHindiSees  up at the " "
Rem 4 ' see http://www.eileenslounge.com/viewtopic.php?f=30&t=31362&p=242769#p242761
    For Cnt = 0 To UBound(arrHindiSees()) Step 2
    Dim MeFukyFormula As String
    ' First Formula row
     Let MeFukyFormula = FuncyFormula(arrHindiSees(Cnt + 1) - 1, arrHindiSees(Cnt))
     Let wsTB.Range("B" & arrHindiSees(Cnt + 1) + 1 & ":AF" & arrHindiSees(Cnt + 1) + 1 & "").Value = MeFukyFormula
    ' Second Formula row
     Let MeFukyFormula = FuncyFormula(arrHindiSees(Cnt + 1), arrHindiSees(Cnt) + 1)
     Let wsTB.Range("B" & arrHindiSees(Cnt + 1) + 2 & ":AF" & arrHindiSees(Cnt + 1) + 2 & "").Value = MeFukyFormula
    Next Cnt
End Sub
Function FuncyFormula(ByVal BL As Long, ByVal TL As Long) As String
Dim Cnt As Long
    For Cnt = BL To TL Step -2
    Dim MeStrungOut As String
     Let MeStrungOut = ",B" & Cnt & MeStrungOut
    Next Cnt
Let MeStrungOut = Replace(MeStrungOut, ",", "", 1, 1, vbBinaryCompare) 'take off just 1 ","
Let FuncyFormula = "=sum(" & MeStrungOut & ")"
End Function