Question : Copy/Paste and sum total in excel

Hi Experts,

I need Experts help to rectify 2 problems in the attached script.

1.Correcting the cut and paste procedure for "total hours" - gray colored row (please refer to the attached .xls files and the detail explanation in the image file). The "Total Hours" row will appear when we click " Total Hours" button.

2. Sum total for KPI hours and Actual hours.

Here's the .xls file together the explanation of the error in image file. Hope Experts can help to overcome this problem.

Code Snippet:

         
           
             1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:

           
           
             Sub CalculateTotalHrs()
    Dim ShObj As Worksheet
    Dim FirstRow As Long
    Dim LastRow As Long
    Dim TotalKPIHrs As String
    Dim TotalActualHrs As String
   
    Set ShObj = ThisWorkbook.Worksheets("Detail Task")
    FirstRow = 7
    LastRow = ShObj.Cells(FirstRow, 2).End(xlDown).Row - 1
   
    TotalKPIHrs = Application.WorksheetFunction.Sum(ShObj.Range(ShObj.Cells(FirstRow, 8), ShObj.Cells(LastRow, 8)))
    TotalActualHrs = Application.WorksheetFunction.Sum(ShObj.Range(ShObj.Cells(FirstRow, 9), ShObj.Cells(LastRow, 9)))
   
    ShObj.Cells(LastRow + 1, 2) = "Total Hours"
    ShObj.Cells(LastRow + 1, 2).Font.Bold = True
    ShObj.Cells(LastRow + 1, 8) = TotalKPIHrs
    ShObj.Cells(LastRow + 1, 9) = TotalActualHrs
    ShObj.Range(ShObj.Cells(LastRow + 1, 8), ShObj.Cells(LastRow + 1, 9)).Font.Bold = True
    ShObj.Range(ShObj.Cells(LastRow + 1, 2), ShObj.Cells(LastRow + 1, 10)).Interior.ColorIndex = 15
   
End Sub

           
         

Open in New Window

Select All

Answer : Copy/Paste and sum total in excel

There you go, Now hit the add-total button, Enclosed is the code and workbook for your reference.

Saurabh...

                       
         
           
             1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:

           
           
             Sub addtotal()
    Application.EnableEvents = False
    Application.ScreenUpdating = False

    Dim rng As Range, lrow As Long
    Dim r1 As Range, cell As Range
    lrow = Cells(Cells.Rows.Count, "b").End(xlUp).Row
    Set rng = Range("B6:K" & lrow)
    rng.Subtotal GroupBy:=1, Function:=xlSum, TotalList:=Array(7, 8), Replace:=True, PageBreaks:=False, SummaryBelowData:=True
    rng.AutoFilter Field:=1, Criteria1:="=*Total*", Operator:=xlAnd
    lrow = Cells(Cells.Rows.Count, "b").End(xlUp).Row
    Set r1 = Range(Range("A6").Offset(1, 0), Range("A" & lrow)).SpecialCells(xlCellTypeVisible)
    For Each cell In r1
        With Range("B" & cell.Row & ":K" & cell.Row)
            With .Borders
                .LineStyle = xlContinuous
                .Weight = xlThin
                .ColorIndex = 24
            End With
            With .Interior
                .ColorIndex = 16
                .PatternColorIndex = xlAutomatic
            End With

        End With
    Next cell
    rng.AutoFilter
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

           
         

Open in New Window

Select All

Daily-Productivity-Ver1-2.xls (159 KB) (File Type Details)

data