Sorting and summation of a spreadsheet

Question

I am working on a sorted data file, so there does not need to be any sorting logic. I find unique values, feed them into an array, then use the worksheetfunction.sum to get totals for a field.

Is this as efficient as I could be, or are there some things I'm not seeing and should?

The "Items" sheet is where a number of accounts are stored (in the thousands). The user cuts and pastes the data from another spreadsheet It is sorted by account, and each line all the columns are identical except for the totals, and the first coloumn which contains the account number.

I collect an array of account numbers, then cycle through the array to find the first instance, and continue down until I find the last instance. Populate a second array with the contents of all cells in that row (up to the last column with a header, then get a sum of the totals, and overwrite that element of the array.

When completed, I drop the entire array made from the items sheet into the summary sheet.

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

Answer 1

Quick Things

First, it's good practice to indent all of your code that way Labels will stick out as obvious.

Second, Worksheets have a CodeName property - View Properties window (F4) and the (Name) field (the one at the top) can be used as the worksheet name. This way you can avoid Dim inws as Worksheet, set inws = Sheets"Items" and instead just use Items.

Comments - "code tell you how, comments tell you why". The code should speak for itself, if it needs a comment, it might need to be made more clear. If not, the comment should describe why you're doing something rather than how you're doing it. Here are a few reasons to avoid comments all together.

Integers - integers are obsolete. According to msdn VBA silently converts all integers to long.

---

Naming

Your variable names leave a lot to be desired. It's pretty easy to use descriptive names and characters are mostly free, so things like

ctr = columnCounter or rowCounter or even just counter.

Also, Standard VBA naming conventions have camelCase for local variables and PascalCase for other variables and names. So inws should be inWS or inWorksheet or sourceWorksheet.

Right now things like zell and distVals don't really tell me anything at all about what I should be expecting them to do.

---

Function

Function GetLast - it's your prerogative, but I think it's unneeded. If you did want you keep it, it would be better as

Private Function GetLast(ByVal choice as Long, ByVal rng as Range) as Long

Right now you're passing ByRef, which isn't best practice and you don't have a return type defined. You can return a row number, column number or address (string?). That can lead to errors down the line if you change what you're looking for and expect the wrong type back. Personally,

Dim lastRow As Long
lastRow = Sheet.Cells(Rows.Count, 1).End(xlUp).Row
Dim lastColumn As Long
lastColumn = Sheet.Cells(1, Columns.Count).End(xlToLeft).Column

Would work fine for me. And you could eliminate all of

Set fndRange = Range(GetLast(3, inws.Cells))
LastCol = fndRange.Column
lastRow = fndRange.Row
Set fndRange = Nothing

---

Arrays

Dim distVals() As String
Dim newRows() As String
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)

I think what's happening here is that you initialize the array, then populate it one cell at a time, assuming that your data is in some sort of order because you're checking only the last element for duplicates, right? That is a lot of redimming and isn't needed. A dictionary could help with that by eliminating duplicates for you

Dim valueDictionary As Object
Set valueDictionary = CreateObject("Scripting.Dictionary")
For counter = 2 To lastRow
    valueDictionary(Cells(counter, 2).Value) = 1
Next

Now arrBound = UBound(distVals) is just valueDictionary.Count

Now, your newRows array is a little confusing to me. Why not just build an array, maybe like this -

    Dim mySummedArray As Variant
    ReDim mySummedArray(1 To valueDictionary.Count, 1 To 2)
    ReDim arr(1 To valueDictionary.Count, 1 To 2)
    counter = 1
    Dim key As Variant
    For Each key In valueDictionary.keys
        mySummedArray(i, 1) = key
        i = i + 1
    Next
    For counter = 1 To valueDictionary.Count
        mySummedArray(counter, 1) = valueDictionary.keys(counter)
    Next
    Dim indexValue As String
    Dim arrayIndex As Long
    For counter = 1 To lastRow
        indexValue = Cells(counter, 1)
        arrayIndex = FindInArray(indexValue, mySummedArray)
        mySummedArray(arrayIndex, 2) = mySummedArray(arrayIndex, 2) + Cells(counter, 2)
    Next

Using

Private Function FindInArray(ByVal indexValue As String, ByVal arrayToSearch As Variant) As Long
    Dim i As Long
    For i = LBound(arrayToSearch) To UBound(arrayToSearch)
        If StrComp(indexValue, arrayToSearch(i, 1), vbTextCompare) = 0 Then
            FindInArray = i
            Exit For
        End If
    Next
End Function

Essentially you end up with a 2D array of unique values paired with their sum. But maybe that's not what you're doing? If not, sorry, but maybe the approach is still useful.