Survey Populate with List, Option Label and Formula, VBA

Question

I am quite a novice. The below code does what I require but I was hoping you could help me speeding it up and simplifying it please. I know should start with basics when learning VBA..but it's just so exciting. Probably it would be faster if I applied For i to x, next i method

Could you please help or guide me to a better solution, simplify/speed up? Thank you in advance

I have:

1. Results sheet2 Range A7:BM107
2. Branches sheet2 B7:B107
3. Questions sheet2 D6:BM6
4. Poor to N/A is rated from 1 to 6
5. Option Labels sheet4 range K23:K28
6. Option Score sheet4 range N23:N28

The code:

• Extracts unique branch names from B7:B110
• Lists them starting from B110
• For each Option Label (Poor, Average,Adequate, Good, Very Good, N/A") it creates Branch List
• For each Branch List under corresponding question it counts Option Score Occurence
• then creates another group for Option 2 and repeats the process
• then creates another group for Option 3 and so on
• Results Look Like this: Results
• Count looks like this:

Count

Sub GetResults()
Dim vaData As Variant
Dim colUnique As Collection
Dim aOutput() As Variant
Dim i As Long
Dim start As Range
Dim BranchesList As Range
Dim LastRow As Long
Dim BC As Integer 'count of dynamic branches
Application.ScreenUpdating = False
Sheet2.Range("B110:Bm500").ClearContents
Sheet2.Range("B110:Bm500").ClearFormats
'///////////////////////// EXTRACT UNIQUE BRANCHES ////////////////////
 'Put the data in an array
 BranchesSurveyed = Sheet2.Range("b7:b107").Value
 'Create a new collection
 Set colUnique = New Collection
 'Loop through the data
 For i = LBound(BranchesSurveyed, 1) To UBound(BranchesSurveyed, 1)
 'Collections can't have duplicate keys, so try to
 'add each item to the collection ignoring errors.
 'Only unique items will be added
 On Error Resume Next
 colUnique.Add BranchesSurveyed(i, 1), CStr(BranchesSurveyed(i, 1))
 On Error GoTo 0
 Next i
 'size an array to write out to the sheet
 ReDim aOutput(1 To colUnique.Count, 1 To 1)
 'Loop through the collection and fill the output array
 For i = 1 To colUnique.Count
 aOutput(i, 1) = colUnique.Item(i)
 Next i
 Set start = Range("b110") 'first cell to contain the list
 'Write the unique values to column B
 start.Resize(UBound(aOutput, 1), UBound(aOutput, 2)).Value = aOutput
 'set range containing current brancheslist
Set BranchesList = Range(start, start.Offset(colUnique.Count - 2, 0))
 'sort names of branches used
 BranchesList.Select
 With Selection
 .Sort key1:=start, order1:=xlAscending, Header:=xlNo
 End With
'////////////////////////// COUNT EACH OPTION FOR EACH BRANCH /////////////////
BC = colUnique.Count
'count option 1
 'add title "Poor"
 With start.Offset(-1)
 .Value = "Count " & Sheet4.Range("K23").Value
 .Font.Bold = True
 End With
 'fill next column with title
 With start.Offset(0, 1).Resize(BC - 1, 1)
 .Value = Sheet4.Range("K23").Value
 End With
 'fill formula for title in question rows
 With start.Offset(0, 2).Resize(BC - 1, 62)
 .FormulaR1C1 = "=IFERROR(IF(RC2="""",0,COUNTIFS(R7C:R107C,Control!R23C14,R7C2:R107C2,RC2)),0)"
 End With
'count option 2
 'add title
 With start.Offset(BC - 1)
 .Value = "Count " & Sheet4.Range("K24").Value
 .Font.Bold = True
 End With
 'copy branches list
 BranchesList.Select
 Selection.Copy start.End(xlDown).Offset(1)
 Application.CutCopyMode = False
 'fill next column with title
 With start.Offset(BC, 1).Resize(BC - 1, 1)
 .Value = Sheet4.Range("K24").Value
 End With
 'fill formula for title in question rows
 With start.Offset(BC, 2).Resize(BC - 1, 62)
 .FormulaR1C1 = "=IFERROR(IF(RC2="""",0,COUNTIFS(R7C:R107C,Control!R24C14,R7C2:R107C2,RC2)),0)"
 End With
'count option 3
 'add title
 With start.Offset(BC * 2 - 1)
 .Value = "Count " & Sheet4.Range("K25").Value
 .Font.Bold = True
 End With
 'copy branches list
 BranchesList.Select
 Selection.Copy start.End(xlDown).Offset(1)
 Application.CutCopyMode = False
 'fill next column with title
 With start.Offset(BC * 2, 1).Resize(BC - 1, 1)
 .Value = Sheet4.Range("K25").Value
 End With
 'fill formula for title in question rows
 With start.Offset(BC * 2, 2).Resize(BC - 1, 62)
 .FormulaR1C1 = "=IFERROR(IF(RC2="""",0,COUNTIFS(R7C:R107C,Control!R25C14,R7C2:R107C2,RC2)),0)"
 End With
'count option 4
 'add title
 With start.Offset(BC * 3 - 1)
 .Value = "Count " & Sheet4.Range("K26").Value
 .Font.Bold = True
 End With
 'copy branches list
 BranchesList.Select
 Selection.Copy start.End(xlDown).Offset(1)
 Application.CutCopyMode = False
 'fill next column with title
 With start.Offset(BC * 3, 1).Resize(BC - 1, 1)
 .Value = Sheet4.Range("K26").Value
 End With
 'fill formula for title in question rows
 With start.Offset(BC * 3, 2).Resize(BC - 1, 62)
 .FormulaR1C1 = "=IFERROR(IF(RC2="""",0,COUNTIFS(R7C:R107C,Control!R26C14,R7C2:R107C2,RC2)),0)"
 End With
'count option 5
 'add title
 With start.Offset(BC * 4 - 1)
 .Value = "Count " & Sheet4.Range("K27").Value
 .Font.Bold = True
 End With
 'copy branches list
 BranchesList.Select
 Selection.Copy start.End(xlDown).Offset(1)
 Application.CutCopyMode = False
 'fill next column with title
 With start.Offset(BC * 4, 1).Resize(BC - 1, 1)
 .Value = Sheet4.Range("K27").Value
 End With
 'fill formula for title in question rows
 With start.Offset(BC * 4, 2).Resize(BC - 1, 62)
 .FormulaR1C1 = "=IFERROR(IF(RC2="""",0,COUNTIFS(R7C:R107C,Control!R27C14,R7C2:R107C2,RC2)),0)"
 End With
'count option 6
 'add title
 With start.Offset(BC * 5 - 1)
 .Value = "Count " & Sheet4.Range("K28").Value
 .Font.Bold = True
 End With
 'copy branches list
 BranchesList.Select
 Selection.Copy start.End(xlDown).Offset(1)
 Application.CutCopyMode = False
 'fill next column with title
 With start.Offset(BC * 5, 1).Resize(BC - 1, 1)
 .Value = Sheet4.Range("K28").Value
 End With
 'fill formula for title in question rows
 With start.Offset(BC * 5, 2).Resize(BC - 1, 62)
 .FormulaR1C1 = "=IFERROR(IF(RC2="""",0,COUNTIFS(R7C:R107C,Control!R28C14,R7C2:R107C2,RC2)),0)"
 End With
 Application.ScreenUpdating = True
End Sub

Answer 1

Turn on Option Explicit. From the VBIDE menu at the top Tools>Options to display the Options dialog>Editor tab>Code Settings group>Require Variable Declaration.

enter image description here

Tick that check box. From that point on Option Explicit will always be added to the top of every new (Standard, Form, Class) module you create. Future-you will thank you. This mandates that all your variables are declared before use IE Dim branchesSurveyed As Range before they can be used. For any existing modules you'll need to go back and add them by hand. Well worth doing because once you do you'll notice that your variable BranchesSurveyed is never actually declared anywhere which means it's a Variant. You can confirm this by stepping into your code (Hotkey: F8) and examining the locals window View>Locals Window.

---

Explicitly declare your Subs as Public. This is achieved by including Public when you declare it as part of the Sub statement. Sub Foo() and Public Sub Foo() are both public but the latter makes your intent explicitly clear because you included the Public keyword.

---

Indentation. You have extra indentation under your EXTRACT UNIQUE BRANCHES banner. No need for that. You will actually refactor that and pull it into its own private method which I'll explain later. Keep indentation consistent, typically 1 TAB within each logical block. The example code block below shows this. The For...Next statement is a logical block, the With statement is another.

Public Sub Foo()
 Dim bar As String
 bar = Sheet1.Range("A1").Value2
 Debug.Print bar
 Dim counter As Long
 For counter = 1 To 10
 Sheet1.Cells(counter, "C").Value2 = counter
 Next
 With Sheet2.Range("A1:A10")
 .NumberFormat = "General"
 .Font.Bold = True
 .Font.Italic = True
 .BorderAround XlLineStyle.xlContinuous, XlBorderWeight.xlThick, Color:=RGB(120, 255, 18)
 End With
End Sub

http://rubberduckvba.com/ can help you with that. It's an open source COM add-in for VBA hosts. Take your original code and paste it into http://rubberduckvba.com/Indentation to indent it an example. Rubberduck (RD) does a lot more than that too.

***Note: I'm a contributing member to RD and openly biased in favor of it.

---

Hungarian Notation (HN) is a holdover from a time long ago. vaData, colUnique, aOutput I'm assuming are using this for Variant, Collection, and Array. If you need to know the type of a variable place your cursor on or within the variable and from the menu Edit>Quick Info (Hotkey: Ctrl+I) to display its type, as shown below. RD warns about common HN prefixes.

enter image description here

---

You have a Wall-of-Declarations at the top. Declare variables right before their use. This has a few benefits. One is it aids in refactoring/restructuring your code by allowing you to get the declaration and first use without a lot of scrolling. A second is it allows you to see unused variables easier. Notice that vaData and LastRow aren't actually used anywhere. They're declared but, never used. With a wall of declarations at the top this is something commonly missed. RD gives code inspections about these unused variables.

---

Static cell references. Sheet2.Range("b7:b107") will break if a row is entered above or a column to the left. How? The cells will shift but your text "b7:b107" won't. To protect yourself from this breaking change use named ranges. These can be added from the Formulas tab>Defined Names group>Name Manager button to display the Name Manager dialog (Hotkey: Ctrl+F3). Click New to display the New Name dialog and enter in the name you want to use. I've assumed the name is BranchLocations.

enter image description here

There are also static references "K23" through "K28". Your variable names are already good. Descriptive variable names make understanding the code a lot easier. Keep it up by doing this with your named ranges too. Future-you will thank present-you for doing so.

---

Headers like '///////////////////////// EXTRACT UNIQUE BRANCHES //////////////////// are a signpost/trail-marker for a dedicated Sub/Function through refactoring. What's refactoring?

Change how somethings being done without changing the result it produces.

You still end up the same result but it's now achieved in a better/improved way. Do this by adding a reference. Do that from the menu Tools>References to display the References dialog. Scroll down to the M's and look for Microsoft Scripting Runtime. Add a check mark and accept with OK.

enter image description here

This new reference gives you access to another assembly (think toolbox as a layman's analogy) that has just the tool you need, a Dictionary object. The Dictionary object has an Exists method (in VBA terms a boolean function) which allows you to check if it already contains the item. As I mentioned previously about the banner comment refactoring, here it is below. The refactoring using the new Dictionary object.

Private Function GetUniqueBranches(ByVal sourceArea As Range) As Scripting.Dictionary
 Set GetUniqueBranches = New Scripting.Dictionary
 Dim surveyCell As Range
 For Each surveyCell In sourceArea
 If Not GetUniqueBranches.Exists(surveyCell.Value2) Then
 GetUniqueBranches.Add surveyCell.Value2, CStr(surveyCell.Value2)
 End If
 Next
End Function

This function is now called as shown below. You supply a source area that is a Range object and it returns you a Dictionary object with the unique values.

Dim uniqueBranches As Scripting.Dictionary
Set uniqueBranches = GetUniqueBranches(Sheet2.Range("BranchLocations"))

---

Implicit sheet references. Set start = Range("b110") is implicitly accessing whatever sheet happens-to-be the active sheet when this code is run. These are ticking time bombs waiting to blow up at the least convenient moment possible. Qualify them with the sheet it's on Sheet2.Range("b110"). Another static cell reference. The unqualified Range also occurs when BranchesList is assigned Set BranchesList = Range(...). And looking at your code that can be condensed down to the code below

Dim branchCount As Long
branchCount = uniqueBranches.Count
Dim start As Range
Set start = Sheet2.Range("UniqueBranchLocations").Cells(1, 1)
'set range containing current brancheslist
Dim BranchesList As Range
Set BranchesList = start.Resize(RowSize:=branchCount)
BranchesList.Value2 = Application.WorksheetFunction.Transpose(uniqueBranches.Items)

---

Range.Select immediately followed by Selection.Anything is another signpost. Rarely is .Select required. Cut out Select and Selection to end up with BranchesList.Sort ...

---

The rest of your logic with Option 1-6 extract that into its own Sub and refactor the logic a bit. It looks/feels like you can consolidate some of the logic into helper functions. Putting all that together you end up with the code below.

Option Explicit
Public Sub GetResults()
 Application.ScreenUpdating = False
 With Sheet2.Range("UniqueBranchLocations")
 .ClearContents
 .ClearFormats
 End With
 Dim uniqueBranches As Scripting.Dictionary
 Set uniqueBranches = GetUniqueBranches(Sheet2.Range("BranchLocations"))
 Dim branchCount As Long
 branchCount = uniqueBranches.Count
 Dim start As Range
 Set start = Sheet2.Range("UniqueBranchLocations").Cells(1, 1)
 Dim BranchesList As Range
 Set BranchesList = start.Resize(RowSize:=branchCount)
 BranchesList.Value2 = Application.WorksheetFunction.Transpose(uniqueBranches.Items)
 BranchesList.Sort key1:=start, order1:=xlAscending, Header:=xlNo
 CountEachOptionForEachBranch start, BranchesList, branchCount
 Application.ScreenUpdating = True
End Sub
Private Function GetUniqueBranches(ByVal sourceArea As Range) As Scripting.Dictionary
 Set GetUniqueBranches = New Scripting.Dictionary
 Dim surveyCell As Range
 For Each surveyCell In sourceArea
 If Not GetUniqueBranches.Exists(surveyCell.Value2) Then
 GetUniqueBranches.Add surveyCell.Value2, CStr(surveyCell.Value2)
 End If
 Next
End Function
Private Sub CountEachOptionForEachBranch(ByVal start As Range, ByVal BranchesList As Range, ByVal branchCount As Long)
 'Refactored code with simplified logic.
End Sub

• Anna Zet: Hello. I didn't expect such a response. You've put so much helpful concise and detailed information that it feels like Christmas. I couldn't wait to get home and get through it. I'll definitely learn lots altho surely come back with more questions.. Thank you!!