Summarize raw data in new sheet, 2.0

Thanks to zak for some great advice on this previous question. This is a follow up question:

I have an Excel workbook with two sheets: "Raw data" and "Summary". In the raw data sheet there are several blocks with data structured like the image below:

I want to create a summary of the data below, in the sheet "Summary", looking like this:

zak suggested that I remove a bunch of Select, and Activate, and to always explicitly state the Worksheet when creating Ranges. I.e. Sheet.Range(), instead of just Range().

The code I have after including the tips from zak is as follows:

`Sub TransferAndSumElements()
Dim wb As Workbook
Dim ws1 As Worksheet
Dim ws2 As Worksheet

Set wb = ActiveWorkbook
Set ws1 = Sheets("Raw data")
Set ws2 = Sheets("Summary")

'##############
' Copy / Paste first row
'##############
ws1.Range("A1:B1").Copy _
Destination:=ws2.Range("A1")

'##############
' Set Item names in summary
'##############

With ws2
.Range("A2").FormulaR1C1 = "Knife"
.Range("A3").FormulaR1C1 = "Fork"
.Range("A4").FormulaR1C1 = "Spoon"
.Range("A5").FormulaR1C1 = "Spork"
.Range("A6").FormulaR1C1 = "Bowl"
End With

'##############
' Find Elements and Sum
'##############

Dim s As Long ' Sum of elements for each Item
Dim str As String ' String in first column in "Summary" (Knife, Fork ...)
Dim cellstr As String ' String in first column in "Raw data" (To be searched through)
Dim DataRange As Range ' All rows in sheet 1 ("Raw data")

ws1.Select ' Select first worksheet ("This worksheet")
LastRow = ws1.Cells.Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row
Set DataRange = Range("A1:A" & LastRow)

For i = 1 To 5 ' Iterate through Knife, Fork .. in "Summary"...

str = ws2.Cells(i + 1, 1).Value ' Extract names
s = 0 '

I'm not sure if this is a programming exercise or an excel exercise, or a programming in excel exercise. Each will have a different answer. But I can give you a few answers to start.

As a first comment. You are right, setting and getting values into excel cells one at a time is not desirable if you can do it in a large chunk.

Lets put a few tools into place.

The type of collection you are wanting to use to collect data is called a dictionary. You can use the dictionary provided in microsoft using the reference "Microsoft Scripting Runtime" the scrrun.dll. This will give you a key value pair to be able to do ..

Dim toolsDictionary As Dictionary
Set toolsDictionary = New Dictionary
...

If Not toolsDictionary.Exists(nextItemName) Then
    toolsDictionary(nextItemName) = 0
End If

Next you'll need to be able to test if a value is a number. This will let you work out if the row you are on is of any value to you. Here you are dealing with excel, not vba.

WorksheetFunction.IsNumber(someVariable)

Then you can also make use of VBA's setter or letter. Given

Dim inputData as Variant
Set inputData = ws2.Range("a1").CurrentRegion   'setter
inputData = ws2.Range("a1").CurrentRegion       'letter

the value of inputData in the setter will be a range object, while the inputData in the letter will contain a 2D array.

Last little tool is an excel tool.

Range.Sort

Lets not bother with just the labels, but we'll copy the whole data set across, and sort it

ws1.Range("A:B").Copy Destination:=ws2.Range("A:b")
ws2.Range("a:b").Sort Key1:=ws2.Range("b1"), Header:=xlYes

Now we have a few useful tools, so we can get on with the job at hand. And just as a warning. This is excel, so there are lots of ways to do this. This is a VBA way.

'get our data and sort
ws1.Range("A:B").Copy Destination:=ws2.Range("A:b")
ws2.Range("a:b").Sort Key1:=ws2.Range("b1"), Header:=xlYes

' load our data into an array
inputData = ws2.Range("a1").CurrentRegion
count = ubound(inputData)

' traverse our data
for counter = 1 to count

    ' is it a tool
    isATool = WorksheetFunction.IsNumber (inputData(counter, 2))
    If isATool Then

        theTool = inputdata(counter,1)
        theNumber = inputdata(counter,2)

        ' check if we have a record
        If Not toolsDictionary.Exists(theTool) Then
            toolsDictionary(theTool) = 0
        End If

        ' accumulate the totals
        toolsDictionary(theTool) = theNumber
        Debug.Print toolsDictionary(theTool)

Once you've got all your data, repopulate your inputData. Make sure we offset by 1 to keep our header.

ws2.range("a1:b1").CurrentRegion.Offset(1).clear

count = toolsDictionary.count

inputData = ws2.range("a2:b2").resize(count)
' you could do 
' ReDim inputData(1 To 5, 1 To 2). But I don't like to.    
for counter = 0 to count - 1    ' dictionary is zero based 
     theTool = toolsDictionary.keys(counter)
     theNumber = toolsDictionary.items(counter)
     inputData(counter + 1, 1) = theTool
     inputData(counter + 1, 2) = theNumber
next counter

ws2.Range("a2:b2").Resize(counter,2).Value2 = inputData

StackExchange Code Review Q#132181, answer score: 6