```
Option Explicit
Sub mkseto3()
Dim wbSrc As Workbook, wbDest As Workbook
Dim ws1 As Worksheet, ws2 As Worksheet
Dim lr As Long, Filename As String, i As Long, arrIn, arrOut
Application.ScreenUpdating = False
Set ws1 = ThisWorkbook.Sheets("Sheet1") '<<<< ~~~ CHANGE REFERENCE IF NEEDED
arrIn = ws1.Cells(1, 1).CurrentRegion
ReDim arrOut(1 To UBound(arrIn), 1 To 5)
For i = 1 To UBound(arrIn)
arrOut(i, 1) = arrIn(i, 1) & arrIn(i, 2) & Format(arrIn(i, 3), "0000")
arrOut(i, 2) = arrIn(i, 6)
arrOut(i, 3) = arrIn(i, 5)
arrOut(i, 4) = arrIn(i, 4)
Next i
Set wbDest = Workbooks.Add(1)
Set ws2 = ActiveSheet
ws2.Cells(1).Resize(1, 5).Value = Array("COUNT", "LABEL_1", "LABEL_2", "LABEL_3", "LABEL_4")
ws2.Cells(2, 2).Resize(UBound(arrOut, 1), UBound(arrOut, 2)).Value = arrOut
lr = ws2.Cells(Rows.Count, 2).End(xlUp).Row
With ws2.Range("A2:A" & lr)
.Formula = "=ROW()-1"
.Value = .Value
End With
ws2.Cells(lr + 1, 1) = "GRAND TOTAL"
ws2.UsedRange.Columns.AutoFit
ws2.Cells(lr + 1, 5).FormulaR1C1 = "=sum(R2C5:R" & lr & "C5)"
lr = lr + 1
With ws2.Range("A1:E1")
.Font.Bold = True
.Interior.ThemeColor = xlThemeColorDark1
.Interior.TintAndShade = -0.15
End With
With ws2.Range(ws2.Cells(lr, 1), ws2.Cells(lr, 5))
.Font.Bold = True
.Interior.ThemeColor = xlThemeColorDark1
.Interior.TintAndShade = -0.15
End With
wbDest.SaveAs ThisWorkbook.Path & "\Results Workbook.xlsx", FileFormat:=51
Application.ScreenUpdating = True
ThisWorkbook.Close 0 '<<< ~~~ DELETE THIS IF YOU WANT workbook_A LEFT OPEN
End Sub
```