Advertisement
Not a member of Pastebin yet?
Sign Up,
it unlocks many cool features!
- 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
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement