Option Explicit


Sub makeSummary()

Dim inws As Worksheet
Dim outws As Worksheet

Dim fndRange As Range
Dim zell As Range

Dim firstRow As Integer
Dim lastRow As Integer
Dim colctr As Integer
Dim totalCol As Integer
Dim LastCol As Integer

Dim ctr As Long
Dim arrBound As Long

Dim distVals() As String
Dim newRows() As String


' Initialize variables
Set inws = Sheets("Items")
Set outws = Sheets("Summary_Sheet")
outws.Cells.Clear
Set fndRange = Range(GetLast(3, inws.Cells))
LastCol = fndRange.Column
lastRow = fndRange.Row
Set fndRange = Nothing

'populate the header columns in the output worksheet.
For ctr = 1 To LastCol
    outws.Cells(1, ctr) = inws.Cells(1, ctr).Value
Next ctr

' redim array, and populate with unique SFC values
ReDim distVals(1)
distVals(1) = inws.Cells(2, 1)
For ctr = 2 To lastRow
    If inws.Cells(ctr, 1).Value <> distVals(UBound(distVals)) Then
        ReDim Preserve distVals(UBound(distVals) + 1)
        distVals(UBound(distVals)) = inws.Cells(ctr, 1).Value
    End If
Next ctr

'Get upper bound of search array and use it to set max row value of newrows array
arrBound = UBound(distVals)
ReDim newRows(1 To arrBound, 1 To LastCol)

'build array,
For ctr = 1 To arrBound
    Set fndRange = inws.Cells.Find(distVals(ctr), lookat:=xlPart, LookIn:=xlFormulas)
    firstRow = fndRange.Row
    lastRow = fndRange.Row
    Do Until inws.Cells(lastRow + 1, 1) <> distVals(ctr)
        lastRow = lastRow + 1
    Loop
'fill row
    For colctr = 1 To LastCol
        newRows(ctr, colctr) = inws.Cells(firstRow, colctr)
    Next colctr
'Get total of totals in SFC
    newRows(ctr, 5) = WorksheetFunction.Sum(Range(inws.Cells(firstRow, 5), inws.Cells(lastRow, 5)))
Next ctr

'clean up of destination sheet
With outws
    .Columns("E").NumberFormat = "_($* #,##0.00_);_($* (#,##0.00);_($* ""-""??_);_(@_)"
    .Range(.Cells(2, 1).Address, .Cells(arrBound + 1, LastCol).Address) = newRows
    'excel doesn't recognize the numbers as numbers unless you multiply by 1 and drop the value back down.
    For Each zell In .Range(.Cells(2, 5).Address, .Cells(arrBound + 1, 5).Address)
        zell.Value = zell.Value * 1
    Next zell
    .Calculate
End With




End Sub

Function GetLast(choice As Long, rng As Range)
    ' 1 = GetLast row
    ' 2 = GetLast column
    ' 3 = GetLast cell

Dim ReturnRng As Range

Set ReturnRng = rng.Find(What:="*", After:=rng.Cells(1), lookat:=xlPart, LookIn:=xlFormulas, _
                SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False)

If Not ReturnRng Is Nothing Then
    With ReturnRng
        Select Case choice
            Case 1
                GetLast = .Row
            Case 2
                GetLast = .Column
            Case 3
                GetLast = .Address
            Case Else
        End Select
    End With
End If
End Function