Code: Select all
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 MeFormula As String
' First Formula row
Let MeFormula = FuncyFormula(arrHindiSees(Cnt + 1) - 1, arrHindiSees(Cnt))
Let wsTB.Range("B" & arrHindiSees(Cnt + 1) + 1 & ":AF" & arrHindiSees(Cnt + 1) + 1 & "").Value = MeFormula
' Second Formula row
Let MeFormula = FuncyFormula(arrHindiSees(Cnt + 1), arrHindiSees(Cnt) + 1)
Let wsTB.Range("B" & arrHindiSees(Cnt + 1) + 2 & ":AF" & arrHindiSees(Cnt + 1) + 2 & "").Value = MeFormula
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