Sum specific rows as even and odd

User avatar
Doc.AElstein
BronzeLounger
Posts: 1499
Joined: 28 Feb 2015, 13:11
Location: Hof, Bayern, Germany

Re: Sum specific rows as even and odd

Post by Doc.AElstein »

Code: https://pastebin.com/66ERgL4C" onclick="window.open(this.href);return false;

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
I am having difficulty logging in with this account just now.
You can find me at DocAElstein also

YasserKhalil
PlatinumLounger
Posts: 4911
Joined: 31 Aug 2016, 09:02

Re: Sum specific rows as even and odd

Post by YasserKhalil »

Thank you very much Mr. Alan
That's working perfect and awesome ..

If I pressed Ctrl + End, to see the usedrange I found it is up to 10009 rows ... This causes the file size to increase
How can I save only to the real used range .. or where's the fault in the code that cause this and how to fix it?

User avatar
Doc.AElstein
BronzeLounger
Posts: 1499
Joined: 28 Feb 2015, 13:11
Location: Hof, Bayern, Germany

Re: Sum specific rows as even and odd

Post by Doc.AElstein »

YasserKhalil wrote:.... or where's the fault in the code that cause this and how to fix it?
I think probably this bit

Code: Select all

       With wsTB.Range("A6:AI10000")
            .ClearContents: .Borders.Value = 0: .Cells.UnMerge: .Interior.Color = xlNone
        End With
Last edited by Doc.AElstein on 05 Dec 2018, 17:02, edited 1 time in total.
I am having difficulty logging in with this account just now.
You can find me at DocAElstein also

YasserKhalil
PlatinumLounger
Posts: 4911
Joined: 31 Aug 2016, 09:02

Re: Sum specific rows as even and odd

Post by YasserKhalil »

Thanks a lot.How to fix that bug?

User avatar
Doc.AElstein
BronzeLounger
Posts: 1499
Joined: 28 Feb 2015, 13:11
Location: Hof, Bayern, Germany

Re: Sum specific rows as even and odd

Post by Doc.AElstein »

Why do you need that code section? What is it supposed to do
I am having difficulty logging in with this account just now.
You can find me at DocAElstein also

YasserKhalil
PlatinumLounger
Posts: 4911
Joined: 31 Aug 2016, 09:02

Re: Sum specific rows as even and odd

Post by YasserKhalil »

The code will be executed a lot and each time the number of names will vary so I put this part so as to clear the results area before starting over

User avatar
Doc.AElstein
BronzeLounger
Posts: 1499
Joined: 28 Feb 2015, 13:11
Location: Hof, Bayern, Germany

Re: Sum specific rows as even and odd

Post by Doc.AElstein »

This would be one way to reduce the used range
This needs to go near the end of the code, you must include the last line or anything similar to reuse the UsedRange: This is because Excel has a quirk/Bug that it maintains a memory of the last UsedRange. That will be refreshed by any use of UsedRange

Code: Select all

'get rid of unused lines
Dim UsedLr As Long: Let UsedLr = wsTB.UsedRange.Row + wsTB.UsedRange.Rows.Count - 1 ' StartRowOfUsedrange + (RowsOfUsedRange-1) = last row of used ramge
Dim DtaLr As Long: Let DtaLr = wsTB.Range("B" & Rows.Count & "").End(xlUp).Row
 wsTB.Rows("" & DtaLr + 1 & ":" & UsedLr & "").Delete Shift:=xlUp
 ' Excel has a quirk: At this point it still holds a memory of the used range ..._
 Let UsedLr = wsTB.UsedRange.Row + wsTB.UsedRange.Rows.Count - 1 ' _... any use of the usedRange will clear the memory
I am having difficulty logging in with this account just now.
You can find me at DocAElstein also

User avatar
Doc.AElstein
BronzeLounger
Posts: 1499
Joined: 28 Feb 2015, 13:11
Location: Hof, Bayern, Germany

Re: Sum specific rows as even and odd

Post by Doc.AElstein »

By the way,
The problem with your logic in your attempt is the following:
You want Mod to work on original data 30 , then 60 , then 90 etc……
But you forgot…
You are changing the original data from like
30 data lines
30 data lines
30 data lines

_... etc
to
30 data lines
3 = 2 totals lines and a spare line
30 data lines
3 = 2 totals lines and a spare line
30 data lines
3 = 2 totals lines and a spare line

So first Mod 30 is OK
But original data 60, will be new data 30 + 3 + 30 = 63
You want to add the three lines not at n = 30 , 60 , …etc.
You want to add the three lines at n= 30 , 63, 96 , …etc.
I would have seen this straight away, if you had more clearly explained your original code. I expect that this was also the problem for others trying to help you.
_.__________________________

This is a modified version of your code, it will work for getting the first 2 30 row data section Sums.
It does not get to sum the last smaller data section

Code: Select all

Sub YassersWay()
    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

    Application.ScreenUpdating = False
        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)
    ' Main loop === To build an output array, b, which will be approx zwice as big as the input data
        For i = LBound(a, 1) To UBound(a, 1) ' each i will be an ID
        Dim CheckFurty As Long ' We want to divide the output into 30 row data sections
    ' First line of data in output array for current i ID
            n = n + 1: CheckFurty = CheckFurty + 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))
    ' Second line of data in output array for current i ID
            n = n + 1: CheckFurty = CheckFurty + 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))
    ' Code section to check if we have just finished adding another 30 lines to data .._
            If CheckFurty = 30 Then '_.. If so we add two lines with totals of last data section
                For c = 2 To 32
                    x = 0
                    For r = (n - 30) + 1 To n Step 2
                        x = x + Val(b(r, c))
                    Next r
                    b(n + 1, c) = x ' Add totals line in output array
    
                    x = 0
                    For r = (n - 30) + 2 To n Step 2
                        x = x + Val(b(r, c))
                    Next r
                    b(n + 2, c) = x ' Add a second totals line in output array
                Next c
                n = n + 3 ' n is the current position in the array for output - we must increase it at least two lines for the two totals lines. We do 3 so we have a free line between data sections
                Let CheckFurty = 0
            End If
        Next i ' go to next i ID
   ' End of main Loop ====================================================0
        wsTB.Range("A6").Resize(UBound(b, 1), UBound(b, 2)).Value = b
    Application.ScreenUpdating = True
'get rid of unused lines
Dim UsedLr As Long: Let UsedLr = wsTB.UsedRange.Row + wsTB.UsedRange.Rows.Count - 1 ' StartRowOfUsedrange + (RowsOfUsedRange-1) = last row of used ramge
Dim DtaLr As Long: Let DtaLr = wsTB.Range("B" & Rows.Count & "").End(xlUp).Row
wsTB.Rows("" & DtaLr + 1 & ":" & UsedLr & "").Delete Shift:=xlUp
' Excel has a quirk: At this point it still holds a memory of the used range ..._
Let UsedLr = wsTB.UsedRange.Row + wsTB.UsedRange.Rows.Count - 1 ' _... any use of the usedRange will clear the memory
End Sub
I am having difficulty logging in with this account just now.
You can find me at DocAElstein also

YasserKhalil
PlatinumLounger
Posts: 4911
Joined: 31 Aug 2016, 09:02

Re: Sum specific rows as even and odd

Post by YasserKhalil »

Thanks a lot Mr. Alan for your great efforts
After many tries I could solve it and edit the original code so as to suit my needs

Code: Select all

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 s           As Long

    Const nRows As Byte = 30
    Const dRows As Byte = 3

    Application.ScreenUpdating = False
        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
        If m = 1 Then Exit Sub
        a = wsSalary.Range("A2:CM" & m).Value
        ReDim b(1 To 2 * (UBound(a, 1) + dRows * 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))
    
            If (n + dRows) Mod (nRows + dRows) = 0 Or UBound(a, 1) = i Then
                For c = 2 To 32
                    x = 0
                    For r = s + 1 To n Step 2
                        x = x + Val(b(r, c))
                    Next r
                    b(n + 1, c) = x
    
                    x = 0
                    For r = s + 2 To n Step 2
                        x = x + Val(b(r, c))
                    Next r
                    b(n + 2, c) = x
                Next c
                n = n + 3
                s = n
            End If
        Next i
    
        wsTB.Range("A6").Resize(UBound(b, 1), UBound(b, 2)).Value = b
    Application.ScreenUpdating = True
End Sub
Now I just need to fix the point of used range ..

User avatar
Doc.AElstein
BronzeLounger
Posts: 1499
Joined: 28 Feb 2015, 13:11
Location: Hof, Bayern, Germany

Re: Sum specific rows as even and odd

Post by Doc.AElstein »

YasserKhalil wrote:...Now I just need to fix the point of used range ..
http://www.eileenslounge.com/viewtopic. ... 20#p242801" onclick="window.open(this.href);return false;
Last edited by Doc.AElstein on 06 Dec 2018, 18:22, edited 2 times in total.
I am having difficulty logging in with this account just now.
You can find me at DocAElstein also

YasserKhalil
PlatinumLounger
Posts: 4911
Joined: 31 Aug 2016, 09:02

Re: Sum specific rows as even and odd

Post by YasserKhalil »

Sorry I didn't see that post. Thank you very much for great and awesome help
Now the problem is completely solved
Best and Kind Regards