Question : Rewrite Copy and Paste Data script

Hi Experts,

I need Experts help to add additional function in the attached script. Copy and Paste new data before "Grand Total" in summary sheet and group the data according to the date. I’ve manually created this in the Summary sheet for Experts to get a better view. I hope Experts can help me to automate this feature.

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

           
           
          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).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, 2).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
With r.Rows(1).Columns(1).Resize(, 4).Borders(xlEdgeTop)
    .LineStyle = xlContinuous
    .Weight = xlThin
End With
End Sub

           
         

Attachments:

CopyData.xls (66 KB) (File Type Details)

xls

Answer : Rewrite Copy and Paste Data script

I don't understand as there i no significant difference between the two versions. If the second works thehe first should have worked.

Anyway, to add your grouping I have added and changed some of the code. I have also attached the the file (with a button to run the macro)

                       
         
           
             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:

           
           
             Sub transferTT2S()
Dim wss As Worksheet, wst As Worksheet, r As Range, r2 As Range
Dim iRows As Long, StartRow As Long
    Set wss = Sheets("Summary")
    Set wst = Sheets("TaskTracker")
    ' Count the rows to be copied (and inserted)
    Set r2 = wst.[A:A].Find("Total Hours").Offset(-1)
    Set r2 = Range(r2, wst.[A7])
    Set r2 = Union(r2, r2.Offset(, 3))
    iRows = r2.Rows.Count
    ' find the next empty row
    Set r = wss.Range("A" & Range("A1").CurrentRegion.Rows.Count)
    StartRow = r.Row
    ' Now insert the number of rows. Select the rows first
    ' as after inserting we need to ungroup them from the previous grouping
    r.EntireRow.Resize.EntireRow.Resize(rowsize:=iRows).Select
    Selection.Insert
    Selection.Rows.Ungroup
    'now copy the data into the inserted rows and format
    Set r = r.Offset(-iRows)
    r.Value = wst.[B3].Value
    r2.Copy
    r.Offset(, 1).PasteSpecial xlPasteValues
    r.Offset(, 2).Resize(r2.Rows.Count, 2).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
    With r.Rows(1).Columns(1).Resize(, 4).Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlThin
    End With
    ' Lastly group the new data
    Rows(StartRow + 1 & ":" & StartRow + iRows - 1).Select
    Selection.Rows.Group

End Sub

           
         