VBA新手求助：实现字符串列表压缩、编码分配及分表结果生成

按钮点击事件代码 #

右键点击预创建的按钮，选择「查看代码」，将以下代码粘贴到模块中：

Sub ProcessData()
    Dim wsSource As Worksheet
    Dim wsCodes As Worksheet
    Dim wsResults As Worksheet
    Dim lastRow As Long
    Dim cell As Range
    Dim uniqueItems As Object
    Dim codeDict As Object
    Dim i As Integer
    
    ' 替换成你的实际工作表名称
    Set wsSource = ThisWorkbook.Worksheets("Sheet1") ' 存储原始B列数据的工作表
    Set wsCodes = ThisWorkbook.Worksheets("Codes")
    Set wsResults = ThisWorkbook.Worksheets("Results")
    
    ' 初始化字典对象，用于存储唯一值和编码对应关系
    Set uniqueItems = CreateObject("Scripting.Dictionary")
    Set codeDict = CreateObject("Scripting.Dictionary")
    
    ' 判断当前执行逻辑：生成唯一值列表 / 同步编码
    If wsCodes.Range("A2").Value = "" Then
        ' ---------- 生成唯一值列表到Codes表 ----------
        lastRow = wsSource.Cells(wsSource.Rows.Count, "B").End(xlUp).Row
        
        ' 遍历B列收集所有非空唯一值
        For Each cell In wsSource.Range("B2:B" & lastRow)
            If cell.Value <> "" And Not uniqueItems.Exists(cell.Value) Then
                uniqueItems.Add cell.Value, cell.Value
            End If
        Next cell
        
        ' 清空Codes表原有内容（保留表头）
        wsCodes.Range("A2:B" & wsCodes.Rows.Count).ClearContents
        
        ' 将唯一值写入Codes表A列
        i = 2
        For Each key In uniqueItems.Keys
            wsCodes.Cells(i, "A").Value = key
            i = i + 1
        Next key
        
        MsgBox "唯一值列表已生成，请在Codes表B列填写对应整数编码。"
    Else
        ' ---------- 同步编码到Results表 ----------
        lastRow = wsCodes.Cells(wsCodes.Rows.Count, "A").End(xlUp).Row
        
        ' 读取Codes表的编码对应关系
        For Each cell In wsCodes.Range("A2:A" & lastRow)
            If cell.Value <> "" And wsCodes.Cells(cell.Row, "B").Value <> "" Then
                codeDict.Add cell.Value, wsCodes.Cells(cell.Row, "B").Value
            End If
        Next cell
        
        ' 清空Results表原有内容
        wsResults.Range("A2:B" & wsResults.Rows.Count).ClearContents
        
        ' 同步分项编号和对应编码
        lastRow = wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).Row
        i = 2
        For Each cell In wsSource.Range("A2:A" & lastRow)
            wsResults.Cells(i, "A").Value = cell.Value ' 写入原始分项编号（假设原始数据A列为编号）
            ' 匹配并写入对应编码
            If codeDict.Exists(wsSource.Cells(cell.Row, "B").Value) Then
                wsResults.Cells(i, "B").Value = codeDict(wsSource.Cells(cell.Row, "B").Value)
            Else
                wsResults.Cells(i, "B").Value = "未匹配编码"
            End If
            i = i + 1
        Next cell
        
        MsgBox "编码已同步到Results表。"
    End If
    
    ' 释放内存对象
    Set uniqueItems = Nothing
    Set codeDict = Nothing
    Set wsSource = Nothing
    Set wsCodes = Nothing
    Set wsResults = Nothing
End Sub

使用步骤 #

• 1. 调整工作表名称：如果你的原始数据不在Sheet1，修改代码中ThisWorkbook.Worksheets("Sheet1")为实际工作表名。
• 2. 设置表头：确保Codes表A1为「字符串」、B1为「编码」；Results表A1为「分项编号」、B1为「对应编码」（可按需修改）。
• 3. 第一次点击按钮：自动提取原始数据B列的唯一值，写入Codes表A列，此时在B列填写整数编码即可。
• 4. 第二次点击按钮：自动读取Codes表的编码对应关系，将分项编号和编码同步到Results表。

常见问题修复 #

• 若代码提示找不到Scripting.Dictionary：打开VBA编辑器→「工具」→「引用」→勾选Microsoft Scripting Runtime，重新运行代码。
• 若编码匹配错误：检查Codes表的字符串和原始数据B列的字符串是否完全一致（注意空格、大小写差异）。

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