subtotal wih conditonally group using VBA - excel

Question

I want to group column name :Check,Code No1,Code 2,Status and total result in Number column according to group using VBA
Data
Result
This is my code:
Sub Sample()
Dim ws As Worksheet, ws1 As Worksheet
Dim LastRowWs As Long, LastRowWs1 As Long, i As Long
Dim Delrange As Range
Application.ScreenUpdating = False
On Error GoTo Whoa
Set ws = Sheets("Sheet1"): Set ws1 = Sheets("Sheet2")
ws1.Cells.Delete
LastRowWs = ws.Range("A" & Rows.Count).End(xlUp).Row
LastRowWs1 = LastRowWs
ws.Range("A1:F" & LastRowWs).Copy ws1.Range("A1")
With ws1
.Columns("A:F").Sort Key1:=.Range("A:F"), Order1:=xlAscending, Key2:=.Range("B2") _
, Order2:=xlAscending, Header:=xlGuess, OrderCustom:=4, MatchCase:= _
True, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, DataOption2 _
:=xlSortNormal
With .Range("A1:F" & LastRowWs1)
.Subtotal GroupBy:=2, Function:=xlSum, TotalList:=Array(5), Replace:=False, _
PageBreaks:=False, SummaryBelowData:=True
.Subtotal GroupBy:=3, Function:=xlSum, TotalList:=Array(5), Replace:=False, _
PageBreaks:=False, SummaryBelowData:=True
.Subtotal GroupBy:=4, Function:=xlSum, TotalList:=Array(5), Replace:=False, _
PageBreaks:=False, SummaryBelowData:=True
End With
LastRowWs1 = .Range("D" & Rows.Count).End(xlUp).Row
'.Rows(LastRowWs1 + 1 & ":" & Rows.Count).ClearContents
.Range("A1:F" & LastRowWs1).Copy
.Range("A1:F" & LastRowWs1).PasteSpecial xlPasteValues
i = LastRowWs1
Do While i > 1
'If InStr(1, .Range("A" & i).Value, "", vbTextCompare) Then
If InStr(1, .Range("D" & i).Value, "Total", vbTextCompare) Then
i = i - 1
Else
If Delrange Is Nothing Then
Set Delrange = .Rows(i - 1)
Else
Set Delrange = Union(Delrange, .Rows(i))
'i = i - 1
End If
End If
i = i - 1
' End If
Loop
If Not Delrange Is Nothing Then Delrange.Delete: Set Delrange = Nothing
LastRowWs1 = .Range("D" & Rows.Count).End(xlDown).Row
'For i = LastRowWs1 To 2 Step -1
For i = 1 To LastRowWs1
If (InStr(1, .Range("D" & i).Value, "Total", vbTextCompare)) Then
.Range("F" & i - 1).Value = .Range("F" & i).Value
If Delrange Is Nothing Then
Set Delrange = .Rows(i)
Else
Set Delrange = Union(Delrange, .Rows(i))
End If
End If
Next i
If Not Delrange Is Nothing Then Delrange.Delete
.Cells.RemoveSubtotal
End With
MsgBox "Vandana, Please check Sheet 'Output' :-)"
LetsContinue:
Application.ScreenUpdating = True
On Error Resume Next
Set ws = Nothing: Set ws1 = Nothing
On Error GoTo 0
Exit Sub
Whoa:
MsgBox Err.Description
Resume LetsContinue
End Sub
But result is like this
●★ 100 101 PG is same column group but sum result is separately

Answer 1

See like this:
Somethings you will need to change in Pivot Visualization:
Tabular Form Data
SubTotals Off
Totals Off
Item repeat for each column
Link to File