Question : Add additional data

Hi Experts,

I need Experts help to rewrite the attached script to be able to copy data from column_E (Task Tracker sheet) and paste it in Column_E (Summary sheet). At present the script only copying data from column_A to D.

Hope Experts could help me to create this feature. Attached as well the workbook for Experts perusal.

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:
31:
32:
33:
34:
35:
36:
37:
38:
39:
40:
41:
42:
43:
44:
45:



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

Attachments:

Add-Info.xls (86 KB) (File Type Details)

xls

Answer : Add additional data

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.Offset(, 4))
r2.Copy
r.Offset(, 1).PasteSpecial xlPasteValues
wss.Range(wss.Cells(r.Row, r.Column + 3), wss.Cells(r.Row + r2.Rows.Count - 1, r.Column + 3)).Cut wss.Cells(r.Row, r.Column + 4)
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