Sub MyMacro()
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim lr As Long
Dim r As Long
Dim r1 As Long
Dim r2 As Long
Dim a As Long
Dim m As Long
Application.ScreenUpdating = False
' Set worksheets
Set ws1 = Sheets("Sheet1")
Set ws2 = Sheets("Sheet2")
' Copy data from first sheet to second
ws1.Cells.Copy
ws2.Select
Range("A1").Activate
ActiveSheet.Paste
Application.CutCopyMode = False
' Find last row with data on second sheet
lr = ws2.Cells(Rows.Count, "A").End(xlUp).Row
' Insert columns A and C and add titles
Columns("A:A").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Columns("D:D").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Range("A1") = "Count"
Range("D1") = "Group"
' Set initial value of row and ASCII code character for group
r = 2
a = 65
' Loop through rows
ws2.Activate
Do
' Exit once past row
If r > lr Then Exit Do
' Put formula in column A and D
Cells(r, "A").FormulaR1C1 = "=COUNTIF(C[4],RC[4])"
Cells(r, "D").Formula = "=CHAR(" & a & ")"
' Merge cells
m = Cells(r, "A").Value
If m > 1 Then
Range(Cells(r, "A"), Cells(r + m - 1, "A")).Merge
Range(Cells(r, "D"), Cells(r + m - 1, "D")).Merge
End If
' Move to next section and increment group
r = r + m
a = a + 1
Loop
' Center columns A and D
With Columns("A:A")
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
With Columns("D:D")
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
Application.ScreenUpdating = True
End Sub