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" &amp; LastRow)

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

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

        For r = 1 To LastRow
            cellstr = ws1.Range("A" &amp; r, "A" &amp; r).Value
            If InStr(cellstr, str) &gt; 0 Then
                s = s + ws1.Range("B" &amp; r, "B" &amp; r).Value
            End If
        Next r

        ws2.Cells(i + 1, 2).FormulaR1C1 = s

    Next i

ws2.Activate

End Sub


Some stuff that I want to improve, but haven't been able to:


Automatically fetch the item names from "Raw data". I've tried creating a Collection, but I end up with an empty row in between the others (Knife, Fork, Spoon, Spork, Blank, Bowl). 


I can loop through this list after creating it, and delete the blank row, but I think there should be a way to do this in one go.

I want to create a list of words ("Knife", "Fork" .. ) and write it to Excel in one command. The way I'm doing it now is to manually write each item name.
Do the loops make sense, or should I do it in some other way? 


And last but not least:


What about the big picture? Does it make sense to do it like this, or should I do it completely different?


Note: The summary can be sorted alphabetically, by number of elements, or not sorted at all. That doesn't matter.



Tab delimited data dump:

Item    Number
Knife   2
Fork    2
Spoon   1
Spork   2

Item    Number
Spork   2
Fork    3

Item    Number
Bowl    3
Knife   5
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