# 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                               ' Initialize sum

For r = 1 To LastRow
cellstr = ws1.Range("A" & r, "A" & r).Value
If InStr(cellstr, str) > 0 Then
s = s + ws1.Range("B" & r, "B" & 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

• A quick suggestion: rename ws1 to RawDataSheet and ws2 to SummarySheet. That way, 6 months from now, you'll know exactly what those variables are without having to rummage through the code to find where they were assigned. Jun 16, 2016 at 13:07

## Naming

Things should sound like what they are. I recommend Joel Spolsky's excellent, classic article on naming (In fact I recommend reading his entire blog, but start there).

Names should be descriptive, unambiguous and concise. In that order.

You have a "Raw Data" worksheet. Call it rawDataSheet. Better yet, give it a codename of rawDataSheet (see @raystafarian's answer on how to do that) and then you don't even have to declare it.

You have a "Summary" sheet. Call it summarySheet.

You have a "sum of elements for each tool" variable. Call it toolCount or toolCounter or numTools.

You have a target tool name variable. Call it targetTool or currentTool or toolName.

You have a current item name variable you're searching through. Call it currentName or elementName or checkName.

And you have a column range which contains all said names to check through. dataRange isn't bad but it's quite generic. rawDataColumn would be more descriptive.

## Dictionaries

Dictionaries are very useful objects. To use them you'll need to set a reference to the Microsoft Scripting Runtime library (Tools -> References -> Microsoft Scripting Runtime).

A Dictionary is a list of keys and items. Each key is unique, and corresponds to exactly one item.

So, for instance, I might create keys for each tool name I want to count (where the items are used as counters). Then, for every name in the raw data, I can go:

With toolCounts '/ toolCounts is our Dictionary object
If .Exists(toolName) Then .Item(toolName) = .Item(toolName) + 1
End With


And at the end, if I want to know how many "knife"s were in the list, I can just go:

knifeCount = toolCounts.Item("Knife")


## Making your code robust and dynamic

These are very important. In essence, you want your code to handle as much work as possible without you having to tell it what to do. Every name you hard-code, every address, every sheet, every range, every number is something you might have to change in the code if your sheet/data changes. Try and design the code so that it will change automatically.

## Change #1: Let your code figure out what tools are in the list.

You know that your tables will have a header of "Item". You know that, apart from blank spaces, everything else in your list will be a tool name. So, rather than having to hardcode every single tool, let's create a function which looks at the data and creates a list of all the unique names it can find:

Option Explicit

Public Const TOOLNAMES_HEADER As String = "Item"
Public Const RAW_DATA_COLUMN As Long = 1 '/ if our column moves, we only need to change it here

Public Function GetUniqueToolNames() As Dictionary
'/ Get a list of all data in RAW_DATA_COLUMN of rawDataSheet.
'/ For each item in the list, if it's not a header, and it's not already in our list, then add it.

Dim finalRow As Long
With rawDatasheet '/ determine the last row containing data in our column.
finalRow = .Cells(.Cells.Count, RAW_DATA_COLUMN).End(xlUp).Row
End With

Dim rawDataRange As Range
With rawDatasheet
Set rawDataRange = .Range(.Cells(1, RAW_DATA_COLUMN_), .Cells(finalRow, RAW_DATA_COLUMN))
End With

Dim rawDataArray As Variant
rawDataArray = rawDataRange
'/ takes all the data in our range and puts it in an array.
'/ the topLeftCell of the range is now in array(1,1). Next row is in (2,1) etc.

Dim toolNames As Dictionary
Set toolNames = newDictionary '/ create our list

Dim emptyCounter As Long '/ will initialise with a default value of 0
Dim elementValue As Variant
Dim elementText As String
Dim iRow As Long

For iRow = 1 To finalRow

elementValue = rawDataArray(iRow, 1) '/ our sheet could contain data that is not text, so our first read is to a Variant variable
elementText = CStr(elementValue) '/ now we convert it to a string

If elementText <> "" And elementText <> TOOLNAMES_HEADER Then '/ ignore headers and empty cells

'/ if the name isn't already in our list, then add it.
With toolNames
If Not .Exists(elementText) Then .Add Key:=elementText, Item:=emptyCounter
End With

End If

Next iRow

Set GetUniqueToolNames = toolNames

End Function


## Change #2: Rather than iterate over the entire list for each item. Iterate once, and sum each item as we go.

With your current code, if you double the number of tools, you'll double the amount of processing. That is going to scale very badly. Now that we have a counter for each item in our dictionary, let's just iterate and count each one as we go.

Public Sub CountTools(ByRef toolNames As Dictionary)
'/ Get a list of all data in RAW_DATA_COLUMN of rawDataSheet.
'/ For each item in the list, increment the relevant counter in the dictionary

End Sub


Hang on a second. We're about to go and grab the raw data again. If you ever find yourself about to repeat yourself, that's a sure sign that the thing you're doing should be refactored into its' own Sub/Function so it can be re-used.

Let's go take the code from change #1 and put it in its' own function:

Public Function GetRawDataList()
'/ Get a list of all data in RAW_DATA_COLUMN of rawDataSheet.

Dim finalRow As Long
With rawDatasheet '/ determine the last row containing data in our column.
finalRow = .Cells(.Cells.Count, RAW_DATA_COLUMN).End(xlUp).Row
End With

Dim rawDataRange As Range
With rawDatasheet
Set rawDataRange = .Range(.Cells(1, RAW_DATA_COLUMN_), .Cells(finalRow, RAW_DATA_COLUMN))
End With

Dim rawDataArray As Variant
rawDataArray = rawDataRange
'/ takes all the data in our range and puts it in an array.
'/ the topLeftCell of the range is now in array(1,1). Next row is in (2,1) etc.

GetRawDataList = rawDataArray

End Function


Now we just need to modify GetUniqueToolNames to use our new function:

Public Function GetUniqueToolNames() As Dictionary
'/ Get a list of all data in RAW_DATA_COLUMN of rawDataSheet.
'/ For each item in the list, if it's not a header, and it's not already in our list, then add it.

Dim rawDataArray As Variant
rawDataArray = GetRawDataList

Dim LB1 As Long, UB1 As Long '/ We no longer know how big the list will be, so let's find out
LB1 = LBound(rawDataArray, 1)
UB1 = UBound(rawDataArray, 1)

Dim toolNames As Dictionary
Set toolNames = newDictionary '/ create our list

Dim emptyCounter As Long '/ will initialise with a default value of 0
Dim elementValue As Variant
Dim elementText As String
Dim iRow As Long

For iRow = LB1 To UB1

elementValue = rawDataArray(iRow, 1) '/ our sheet could contain data that is not text, so our first read is to a Variant variable
elementText = CStr(elementValue) '/ now we convert it to a string

If elementText <> "" And elementText <> TOOLNAMES_HEADER Then '/ ignore headers and empty cells

'/ if the name isn't already in our list, then add it.
With toolNames
If Not .Exists(elementText) Then .Add Key:=elementText, Item:=emptyCounter
End With

End If

Next iRow

Set GetUniqueToolNames = toolNames

End Function


## Awesome. Where were we? Oh yeah:

Public Sub CountTools(ByRef toolNames As Dictionary)
'/ Get a list of all data in RAW_DATA_COLUMN of rawDataSheet.
'/ For each item in the list, increment the relevant counter in the dictionary

End Sub


Now let's get to counting:

Public Sub CountTools(ByRef toolNames As Dictionary)
'/ Get a list of all data in RAW_DATA_COLUMN of rawDataSheet.
'/ For each item in the list, increment the relevant counter in the dictionary

Dim rawDataArray As Variant
rawDataArray = GetRawDataList

Dim LB1 As Long, UB1 As Long '/ We no longer know how big the list will be, so let's find out
LB1 = LBound(rawDataArray, 1)
UB1 = UBound(rawDataArray, 1)

Dim elementValue As Variant
Dim elementText As String
Dim iRow As Long

For iRow = LB1 To UB1

elementValue = rawDataArray(iRow, 1)
elementText = CStr(elementValue)

With toolNames
If .Exists(elementText) Then .Item(elementText) = .Item(elementText) + 1
End With

Next iRow

End Sub


Hang on a second. This code is nearly identical to our "find unique names" procedure. You know, with a small tweak, we could combine them into one operation so we only iterate over the data once rather than twice:

    For iRow = LB1 To UB1

elementValue = rawDataArray(iRow, 1) '/ our sheet could contain data that is not text, so our first read is to a Variant variable
elementText = CStr(elementValue) '/ now we convert it to a string

If elementText <> "" And elementText <> TOOLNAMES_HEADER Then '/ ignore headers and empty cells

With toolCounts
If Not .Exists(elementText) Then
'/ if the name isn't already in our list, then add it.
Else
'/ else increment the counter
.Item(elementText) = .Item(elementText) + 1
End If
End With

End If

Next iRow


## And now our main procedure is simply:

Sub TransferAndSumElements()

Dim toolCounts As Dictionary
Set toolCounts = GetToolCounts

'/ code to Print contents to summarySheet

End Sub


With the rest nicely abstracted away elsewhere:

Public Function GetToolCounts()
'/ Get a list of all data in RAW_DATA_COLUMN of rawDataSheet.
'/ For each item in the list:
'/ if it's not in our list of toolNames, add it, set its' counter to 1
'/ if it is in our list, increment its' counter by 1

Dim rawDataArray As Variant
rawDataArray = GetRawDataList

Dim LB1 As Long, UB1 As Long '/ We no longer know how big the list will be, so let's find out
LB1 = LBound(rawDataArray, 1)
UB1 = UBound(rawDataArray, 1)

Dim toolCounts As Dictionary
Set toolCounts = newDictionary '/ create our list

Dim elementValue As Variant
Dim elementText As String
Dim iRow As Long

For iRow = LB1 To UB1

elementValue = rawDataArray(iRow, 1) '/ our sheet could contain data that is not text, so our first read is to a Variant variable
elementText = CStr(elementValue) '/ now we convert it to a string

If elementText <> "" And elementText <> TOOLNAMES_HEADER Then '/ ignore headers and empty cells

With toolCounts
If Not .Exists(elementText) Then
'/ if the name isn't already in our list, then add it.
Else
'/ else increment the counter
.Item(elementText) = .Item(elementText) + 1
End If
End With

End If

Next iRow

Set GetToolCounts = toolNames

End Function

Public Function GetRawDataList()
'/ Get a list of all data in RAW_DATA_COLUMN of rawDataSheet.

Dim finalRow As Long
With rawDatasheet '/ determine the last row containing data in our column.
finalRow = .Cells(.Cells.Count, RAW_DATA_COLUMN).End(xlUp).Row
End With

Dim rawDataRange As Range
With rawDatasheet
Set rawDataRange = .Range(.Cells(1, RAW_DATA_COLUMN_), .Cells(finalRow, RAW_DATA_COLUMN))
End With

Dim rawDataArray As Variant
rawDataArray = rawDataRange
'/ takes all the data in our range and puts it in an array.
'/ the topLeftCell of the range is now in array(1,1). Next row is in (2,1) etc.

GetRawDataList = rawDataArray

End Function


Now we just print each tool to our summary sheet:

Sub TransferAndSumElements()

Dim toolCounts As Dictionary
Set toolCounts = GetToolCounts

Const NAME_COLUMN As Long = 1
Const COUNT_COLUMN As Long = 2
Const START_ROW As Long = 1

Dim iRow As Long
Dim key As Variant
With summarySheet

iRow = START_ROW
.Cells(iRow, NAME_COLUMN) = "Tool Name"
.Cells(iRow, COUNT_COLUMN) = "Count"

For Each key In toolCounts.Keys()
iRow = iRow + 1
.Cells(iRow, NAME_COLUMN) = key
.Cells(iRow, COUNT_COLUMN) = toolCounts.Item(key)
Next key

End With

End Sub


There are now just 5 hard-coded variables in our code. Data moves? Change RAW_DATA_COLUMN. Headers change? modify TOOLNAMES_HEADER. Want to move the summary data around? just change

    Const NAME_COLUMN As Long = 1
Const COUNT_COLUMN As Long = 2
Const START_ROW As Long = 1


to suit. Everything else will handle itself without further intervention.

• A really thorough handling of the issue. Jun 17, 2016 at 12:19
• "Don't write comments such as Thanks, +1 etc." Screw it: Thanks!! Jun 24, 2016 at 7:21

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")


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")

' 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


Always turn on Option Explicit. You can have it automatically by going to Tools -> Options in the VBE and checking the Require Variable Declaration option. This way if you have any variables not defined, the compiler will let you know.

Why do you want to know? For instance you don't declare "LastRow."

When you don't define your variable, VBA will declare it as a Variant, which are objects:

Performance. A variable you declare with the Object type is flexible enough to contain a reference to any object. However, when you invoke a method or property on such a variable, you always incur late binding (at run time). To force early binding (at compile time) and better performance, declare the variable with a specific class name, or cast it to the specific data type.

By not declaring variables, you could possibly be paying a penalty.

### Naming

Oh that naming. Use descriptive naming so your code is easy to follow and explicit in what it's doing for you when you go back to it or someone else takes a look at it. What is s, i or r? What are the ws1 and ws2 - if you need numbers in your variable names, you aren't being explicit enough.

Hey, worksheets! 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 Sheets("Sheet1") and instead just use Sheet1.

Standard VBA naming conventions have camelCase for local variables and PascalCase for other variables and names. For instance LastRow should be lastRow.

Why are you making these formulas?

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


Also for something like this, I would recommend using a loop so it scales

 ws1.Range("A1:B1").Copy _
Destination:=ws2.Range("A1")


Dim i As Long
For i = 1 To 2
Sheet1.Cells(1, i) = Sheet2.Cells(1, i)
Next


This is very superfluous

ws1.Select              ' Select first worksheet ("This worksheet")


Why? The same goes for

ws2.Activate


Here it would be good to use cells() instead of that Range

   cellstr = ws1.Range("A" & r, "A" & r).Value
If InStr(cellstr, str) > 0 Then
s = s + ws1.Range("B" & r, "B" & r).Value

• How does the loop scale better than the Range.Copy statement? Jun 16, 2016 at 13:43
• @AlanT interacting with the sheet is slower than doing it directly. Jun 16, 2016 at 13:49