将Excel表格中的项目列表转换为逗号分隔的string

Excel（Table1）中有一个表格，其中包含以下列标题：员工姓名，许可状态和许可证状态。 表格的一个例子是：

John Adams NY Active John Adams PA Active John Adams NJ Inactive Ralph Ames MS Active Ed Turner MS Pending 

我想要设置一个摘要选项卡，每个员工有一行，列有活动许可证，待处理许可证和非活动许可证，这些单元格将显示适当状态代码的逗号分隔列表。 例如：

 Name Active Pending Inactive John Adams NY, PA NJ Ralph Ames MS Ed Turner MS 

我只是好奇到达这个自定义列表的最佳方式。 我写了下面的函数似乎工作正常，它比我预期的运行速度快，但它似乎效率低，因为它遍历整个表每一次，我已经粘贴到几百个单元格的公式：

 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 

有没有办法可能使用VBA来运行类似于SQL的查询，所以我只是循环遍历SQL结果而不是整个表每一次？ 我认为这也有助于将摘要列表按字母顺序排列。 或者也许还有其他更好的方法，我没有想到。

Answer 1

好的，所以这里是一个使用Scripting Dictionaries的例子。

我有一个工作表上的这张表：

输出结果应该产生一个新的工作表，其中包含如下的总结数据：

我试图很好地logging它，但是如果您有任何疑问，请告诉我。

 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