Sub transferTT2S()
Dim wss As Worksheet, wst As Worksheet, r As Range, r2 As Range
Set wss = Sheets("Summary")
Set wst = Sheets("TaskTracker")
' remove all existing data
' wss.UsedRange.Offset(1).ClearContents
' -- or --
' find the next empty row
Set r = wss.UsedRange.Rows(wss.UsedRange.Rows.Count - 1).EntireRow.Cells(1)
r.EntireRow.Delete
Set r = wss.UsedRange.Rows(wss.UsedRange.Rows.Count).Offset(1).EntireRow.Cells(1)
r.Value = wst.[B3].Value
Set r2 = wst.[A:A].Find("Total Hours").Offset(-1)
Set r2 = Range(r2, wst.[A7])
Set r2 = Union(r2, r2.Offset(, 3))
r2.Copy
r.Offset(, 1).PasteSpecial xlPasteValues
r.Offset(, 2).Resize(r2.Rows.Count, 3).NumberFormat = "[h]:mm:ss"
r.Offset(, 2).Resize(r2.Rows.Count, 2).HorizontalAlignment = xlCenter
r.Offset(, 3).Value = r2.Rows(r2.Rows.Count).Cells(1).Offset(1, 1).Value
r.Offset(r2.Rows.Count, 0).Value = "Sum Total"
With r.Offset(r2.Rows.Count, 3)
.Value = "=SUM(D1:D" & r.Offset(0, 0).Row + r2.Rows.Count - 1 & ")"
.NumberFormat = "[h]:mm:ss"
End With
With r.Offset(r2.Rows.Count).Resize(1, 4)
.Borders(xlEdgeTop).LineStyle = xlDouble
.Borders(xlEdgeBottom).LineStyle = xlDouble
End With
With r.Rows(1).Columns(1).Resize(, 4).Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
End With
Dim i, irow As Long
wss.Range("A1").ClearOutline
irow = wss.Range("A2:A65536").SpecialCells(xlCellTypeLastCell).Row - 1
Set r = wss.Range("A2")
While r.Row < irow
Set r = r.Offset(1)
Range(r, r.End(xlDown).Offset(-1)).Rows.Group
Set r = r.End(xlDown)
Wend
wss.Outline.ShowLevels RowLevels:=1
End Sub
|