Convert list of items in an Excel Table to comma-separated string - excel

Question

I have a table in Excel (Table1) that has these column headings: employee name, state licensed, and license status. A sample of the table would be:
John Adams NY Active
John Adams PA Active
John Adams NJ Inactive
Ralph Ames MS Active
Ed Turner MS Pending
I want to set up a summary tab that has one row per employee with a column for active licenses, pending licenses, and inactive licenses, and those cells would display a comma-separated list of the appropriate state codes. For example:
Name Active Pending Inactive
John Adams NY, PA NJ
Ralph Ames MS
Ed Turner MS
I'm just curious about the best way to get to this custom list. I wrote the function below which seems to work fine, and it runs faster than I expected, but it just seems inefficient because it loops through the entire table every time, and I've pasted formulas referencing this function to a few hundred cells:
Function comma_state_list(the_name As String, the_status As String) As String
Dim ws As Worksheet
Dim oLo As ListObject
Dim oCol As ListColumns
Set ws = Worksheets("State Licenses")
Set oLo = ws.ListObjects("Table1")
Set oCol = oLo.ListColumns
For i = 1 To oLo.ListRows.Count
If oLo.Range(i, 1).Value = the_name And oLo.Range(i, 3) = the_status Then
comma_state_list = comma_state_list & oLo.Range(i, 4) & ", "
End If
Next i
If Len(comma_state_list) = 0 Then
comma_state_list = ""
Else
comma_state_list = Left(comma_state_list, Len(comma_state_list) - 2)
End If
End Function
Is there a way to maybe use VBA to run a SQL-like query against the table so I'm just looping through the SQL result instead of the entire table every time? I was thinking this would help to alphabetize the summary list too. Or maybe there's some other better way I'm not thinking of.

Answer 1

OK, so here is an example using Scripting Dictionaries.
I have this table on one worksheet:
And the output should produce a new worksheet with summary data like:
I tried to document it pretty thoroughly but let me know if you have any questions about it.
Option Explicit
Sub Test()
Dim wsCurr As Worksheet: Set wsCurr = ActiveSheet
Dim wsNew As Worksheet 'output container'
Dim rowNum As Long 'row number for output'
'Scripting dictionaries:'
Dim inactiveDict As Object
Dim activeDict As Object
Dim key As Variant
'Table variables'
Dim rng As Range 'table of data'
Dim r As Long 'row iterator for the table range.'
'information about each employee/row'
Dim empName As String
Dim state As String
Dim status As String
'Create our dictionaries:'
Set activeDict = Nothing
Set inactiveDict = Nothing
Set activeDict = CreateObject("Scripting.Dictionary")
Set inactiveDict = CreateObject("Scripting.Dictionary")
Set rng = Range("A1:C6") 'better to set this dynamically, this is just an example'
For r = 2 To rng.Rows.Count
empName = rng(r, 1).Value
state = rng(r, 2).Value
status = rng(r, 3).Value
Select Case UCase(status)
Case "ACTIVE"
AddItemToDict activeDict, empName, state
Case "INACTIVE"
AddItemToDict inactiveDict, empName, state
End Select
Next
'Add a new worksheet with summary data'
Set wsNew = Sheets.Add(After:=wsCurr)
With wsNew
.Cells(1, 1).Value = "Name"
.Cells(1, 2).Value = "Active"
.Cells(1, 3).Value = "Inactive"
rowNum = 2
'Create the initial table with Active licenses'
For Each key In activeDict
.Cells(rowNum, 1).Value = key
.Cells(rowNum, 2).Value = activeDict(key)
rowNum = rowNum + 1
Next
'Now, go over this list with inactive licenses'
For Each key In inactiveDict
If activeDict.Exists(key) Then
rowNum = Application.Match(key, .Range("A:A"), False)
Else:
rowNum = Application.WorksheetFunction.CountA(wsNew.Range("A:A")) + 1
.Cells(rowNum, 1).Value = key
End If
.Cells(rowNum, 3).Value = inactiveDict(key)
Next
End With
'Cleanup:
Set activeDict = Nothing
Set inactiveDict = Nothing
End Sub
Sub AddItemToDict(dict As Object, empName As String, state As String)
'since we will use the same methods on both dictionary objects, '
' it would be best to subroutine this action:'
Dim key As Variant
'check to see if this employee already exists'
If UBound(dict.Keys) = -1 Then
dict.Add empName, state
Else:
If Not dict.Exists(empName) Then
'If IsError(Application.Match(empName, dictKeys, False)) Then
'employee doesn't exist, so add to the dict'
dict.Add empName, state
Else:
'employee does exist, so update the list:'
'concatenate the state list'
state = dict(empName) & ", " & state
'remove the dictionary entry'
dict.Remove empName
'add the updated dictionary entry'
dict.Add empName, state
End If
End If
End Sub