7
\$\begingroup\$

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:

enter image description here

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

enter image description here

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
\$\endgroup\$
  • 1
    \$\begingroup\$ 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. \$\endgroup\$ – FreeMan Jun 16 '16 at 13:07
3
\$\begingroup\$

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.
                    .Add Key:=elementText, Item:=1
                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.
                    .Add Key:=elementText, Item:=1
                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.

\$\endgroup\$
  • 1
    \$\begingroup\$ A really thorough handling of the issue. \$\endgroup\$ – Gareth Jun 17 '16 at 12:19
  • 1
    \$\begingroup\$ "Don't write comments such as Thanks, +1 etc." Screw it: Thanks!! \$\endgroup\$ – Stewie Griffin Jun 24 '16 at 7:21
6
\$\begingroup\$

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
\$\endgroup\$
5
\$\begingroup\$

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

instead

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
\$\endgroup\$
  • \$\begingroup\$ How does the loop scale better than the Range.Copy statement? \$\endgroup\$ – AlanT Jun 16 '16 at 13:43
  • \$\begingroup\$ @AlanT interacting with the sheet is slower than doing it directly. \$\endgroup\$ – Raystafarian Jun 16 '16 at 13:49

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.