请求编写/修复Excel VBA宏：按分类整理精神疾病症状列表

需求概述 #

需实现以下核心功能：

• 按**列（分类）**排序输出选中的症状
• 合并同后缀的冗余前缀（例如将poor hygiene和poor grooming合并为poor hygiene and grooming，多前缀场景遵循a, b, and c + 后缀格式）
• 严格遵循标点规范：同分类内症状用逗号分隔，不同分类间用分号分隔，最后一项前添加and

表格结构 #

• A1：用于输出最终整理后的症状列表
• 第2-5行：预留空白行
• 第6行：列标题行
• 数据范围：A7:AL1000
• 奇数列（A、C、E等）：空白或填写x，标记选中右侧相邻偶数列的症状
• 偶数列（B、D、F等）：存储具体症状文本

示例输出 #

示例1（选中指定基础症状）：
poor hygiene and grooming, disheveled appearance, labile and dysregulated mood, and mood-incongruent affect

示例2（额外选中C/D列的elevated mood）：
poor hygiene and grooming; disheveled appearance; labile, dysregulated, and elevated mood; and mood-incongruent affect

现有代码问题 #

1. 未按列（分类）排序：使用无序字典存储后缀，导致输出顺序混乱
2. 前缀合并逻辑错误：拆分后的前缀未正确关联到原分类，导致同组症状被拆分为独立项

修复后的VBA代码 #

Sub GenerateSymptomSummary()
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets(1)
    
    Dim dataRange As Range
    Set dataRange = ws.Range("A7:AL1000")
    
    ' 存储每个分类（列组）的症状分组，按列顺序保存
    Dim categoryGroups As Collection
    Set categoryGroups = New Collection
    
    Dim checkCol As Long, textCol As Long
    Dim rowNum As Long
    Dim checkVal As String, symptom As String
    Dim prefix As String, suffix As String
    Dim lastSpace As Long
    
    ' 按列组遍历（每两列为一个分类），确保分类顺序与列顺序一致
    For checkCol = 1 To dataRange.Columns.Count Step 2
        textCol = checkCol + 1
        Dim currentCategory As Object
        Set currentCategory = CreateObject("Scripting.Dictionary")
        
        ' 遍历当前列组的所有行
        For rowNum = 1 To dataRange.Rows.Count
            checkVal = Trim(dataRange.Cells(rowNum, checkCol).Value)
            symptom = Trim(dataRange.Cells(rowNum, textCol).Value)
            
            If LCase(checkVal) = "x" And symptom <> "" Then
                ' 拆分前缀和后缀
                lastSpace = InStrRev(symptom, " ")
                If lastSpace > 0 Then
                    prefix = Trim(Left(symptom, lastSpace - 1))
                    suffix = Trim(Mid(symptom, lastSpace + 1))
                Else
                    prefix = ""
                    suffix = symptom
                End If
                
                ' 给当前后缀添加前缀（去重）
                If Not currentCategory.exists(suffix) Then
                    currentCategory.Add suffix, New Collection
                End If
                
                Dim exists As Boolean
                exists = False
                For Each item In currentCategory(suffix)
                    If item = prefix Then
                        exists = True
                        Exit For
                    End If
                Next item
                If Not exists Then
                    currentCategory(suffix).Add prefix
                End If
            End If
        Next rowNum
        
        ' 如果当前分类有选中的症状，加入分类集合
        If currentCategory.Count > 0 Then
            categoryGroups.Add currentCategory
        End If
    Next checkCol

    ' 构建最终输出列表
    Dim finalList As Collection
    Set finalList = New Collection
    
    Dim cat As Variant
    Dim key As Variant
    Dim entry As String
    Dim prefixes As Collection
    
    ' 按分类顺序处理
    For Each cat In categoryGroups
        For Each key In cat.keys
            Set prefixes = cat(key)
            
            ' 生成单条症状文本
            If prefixes.Count = 1 And prefixes(1) = "" Then
                entry = key
            ElseIf prefixes.Count = 1 Then
                entry = prefixes(1) & " " & key
            Else
                entry = JoinWithCommas(prefixes) & " " & key
            End If
            
            finalList.Add entry
        Next key
    Next cat
    
    ' 生成最终字符串并输出到A1
    ws.Range("A1").Value = JoinWithSemicolonsAndAnd(finalList)
End Sub

' 合并前缀为规范的逗号+and格式
Function JoinWithCommas(col As Collection) As String
    Dim result As String
    Dim i As Long
    Select Case col.Count
        Case 0
            result = ""
        Case 1
            result = col(1)
        Case 2
            result = col(1) & " and " & col(2)
        Case Else
            result = col(1)
            For i = 2 To col.Count - 1
                result = result & ", " & col(i)
            Next i
            result = result & ", and " & col(col.Count)
    End Select
    JoinWithCommas = result
End Function

' 合并分类项为规范的分号+and格式
Function JoinWithSemicolonsAndAnd(col As Collection) As String
    Dim result As String
    Dim i As Long
    Select Case col.Count
        Case 0
            result = ""
        Case 1
            result = col(1)
        Case 2
            result = col(1) & " and " & col(2)
        Case Else
            result = col(1)
            For i = 2 To col.Count - 1
                result = result & "; " & col(i)
            Next i
            result = result & "; and " & col(col.Count)
    End Select
    JoinWithSemicolonsAndAnd = result
End Function

代码修复关键点 #

1. 按分类顺序存储：将每两列作为一个分类，按列顺序遍历并存储分类信息，确保输出顺序与表格列顺序一致
2. 优化前缀合并逻辑：在每个分类内部按后缀分组，合并重复前缀，确保同后缀的症状被正确合并
3. 规范标点格式：优化JoinWithCommas和JoinWithSemicolonsAndAnd函数，针对2个项和多个项分别处理，严格遵循英文标点规范
4. 去重处理：在添加前缀到集合时检查是否已存在，避免重复项

内容的提问来源于stack exchange，提问作者Alexa Lambros