Instead of re-inventing the wheel...
Sub sheetfix()
Set sht = ws
With sht
'.Activate
Tot = 0: lrow = .Range("A" & Rows.Count).End(xlUp).Row
.Range("A6:F" & lrow).Sort key1:=.Range("A6"), Order1:=xlAscending
.Range("A5:A" & lrow).Font.Bold = True
With .UsedRange.Rows
Range(.Cells(5, 1), .Cells(.Count, 1)).AdvancedFilter xlFilterCopy, , .Range("P1"), True
With .Range("P1").CurrentRegion: Val = .Value: .Clear: End With
End With
For i = 2 To UBound(Val)
.Range("A5:F" & lrow).AutoFilter 1, Val(i, 1)
numrows = .AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Cells.Count - 1
If numrows = 1 Then
sr = .Range("A" & Rows.Count).End(xlUp).Row
Else
sr = .Range("A6", .Range("A" & Rows.Count).End(xlUp)).SpecialCells(12).Row
End If
lr = .Range("A" & Rows.Count).End(xlUp).Row: diff = numrows - (lr - sr)
If numrows > 1 Then
.Rows(lr + diff).Insert
.Range("E" & sr & ":E" & lr).Cut Destination:=.Range("A" & sr + 1)
For ii = 1 To numrows + 1
.Range("A" & sr + ii) = Space(5) & .Range("A" & sr + ii)
Next ii
.Range("F" & sr & ":F" & lr).Cut Destination:=.Range("E" & sr)
.Range("B" & sr & ":E" & lr).Cut Destination:=.Range("B" & sr + 1)
.Rows(lr + diff + 1).Insert
.Range("A" & lr + diff + 1) = Val(i, 1) & " Total"
.Range("E" & lr + diff + 1) = Application.Sum(.Range("E" & sr + 1 & ":E" & lr + diff + 1))
Tot = Tot + .Range("E" & lr + diff + 1).Value
.Range("A" & lr + diff + 1 & ":E" & lr + diff + 1).Interior.ColorIndex = 24
.Range("A" & lr + diff + 1 & ":E" & lr + diff + 1).Font.Bold = True
Else
.Range("E" & lr).Cut
.Rows(lr + 1).Insert: .Range("A" & lr + 1) = Space(5) & .Range("A" & lr + 1)
.Range("F" & lr).Cut Destination:=.Range("E" & lr)
.Range("B" & lr & ":E" & lr).Cut Destination:=.Range("B" & lr + 1)
.Rows(lr + 2).Insert
.Range("A" & lr + 2) = Val(i, 1) & " Total"
.Range("E" & lr + 2) = Application.Sum(.Range("E" & lr + 1 & ":E" & lr))
Tot = Tot + .Range("E" & lr + 2).Value
.Range("A" & lr + 2 & ":E" & lr + 2).Interior.ColorIndex = 24
.Range("A" & lr + 2 & ":E" & lr + 2).Font.Bold = True
End If
Next i
.AutoFilterMode = False
lr = .Range("E" & Rows.Count).End(xlUp).Row
.Range("A" & lr + 1) = "Totals": .Range("E" & lr + 1) = Tot
With .Range("A" & lr + 1 & ":E" & lr + 1)
.Font.Bold = True
.Borders(xlEdgeBottom).Weight = xlThick
.Borders(xlEdgeBottom).ColorIndex = 55
.Borders(xlEdgeBottom).LineStyle = xlDouble
End With
.Columns("E:E").NumberFormat = "0.00"
.Columns("A:E").Columns.AutoFit
End With
End Sub
Bookmarks