Issues subtotaling and breaking down the subtotal outline to obtain records for copying.

[Chris101]

I download each month a report that provides a list of telephone numbers that I keep track of to show how many incoming calls were made to one of our call centers and the duration of those calls.

What I am doing is placing the downloaded data into the worksheet "Original Data". From There I move the data to the sheet labeled "Raw Data" where I sort from lowest to highest on the column "F" ("Transfer Dest") and then subtotal (sum) on column "J" ("Duration").

Where I am having an issue is that I cannot write vba to collapse the outline to give me only the Total Transfer Dest numbers. Once I have only the records for the Total Transfer Dest numbers, I do not know how to copy those records and paste them into the sheet labeled Import to DB. When I try to paste the numbers, it seems to paste all of the telephone numbers and not just the telephone numbers that have totals. For example, I sort and subtotal on the worksheet "Raw Data Sheet with sort and subtotal" which is attached for reference. Then what I would like to do is collapse the outline to have only the records that have the totals appearing in column "F" ("Transfer Dest"). An example is located in the worksheet "sourcexferusage..." which is attached for reference. lastly I would like to copy and paste those records into the sheet labeled "Sheet import to DB" See sample workseet "Sheet Import to DB..." for reference.

In my example data i have 20 records. After I collapse the outline i have 3 records. when i try and paste those records, I end up pasting 22 records instead of the 3.

I have attached my code for the sort and subtotal but I have given up on trying to figure out how to collapse the outline and copy only those records appearing in the outline.

I know I am asking for a lot of assistance on this project, and I greatly appreciate your time and assistance in helping me resolve this problem.

Thank you in advance for your time and effort.

Here is my code so far:

Option Explicit
Sub subtotal()

Dim wsh7 As Worksheet
Dim lastrow As Integer
Dim rng As Range

Set wsh7 = ThisWorkbook.Sheets("Raw Data")

wsh7.Activate
'wsh7.Range("A1").EntireRow.Delete
    
wsh7.Columns.AutoFit
    
     lastrow = wsh7.Cells(wsh7.Rows.Count, "A").End(xlUp).Row
     
 With wsh7
    With .Sort
        .SortFields.Clear
        .SortFields.Add2 Key:=wsh7.Range("F2:F" & lastrow), SortOn:=xlSortOnValues, _
            Order:=xlAscending, DataOption:=xlSortNormal
        .SetRange wsh7.Range("A2:L" & lastrow)
        '.Header -xlYes
        '.Orientation -xlTopToBottom
        .Apply
    End With


Set rng = .Range("A1:L" & lastrow)


rng.subtotal groupby:=6, Function:=xlSum, totalList:=Array(10), Replace:=True, _
pagebreaks:=False, summarybelowdata:=True

End With
End Sub