如何修改VBA拆分列代码，将同组公司合并至同一工作表？

Sub Step1_SplitByGroup()
    Dim lr As Long
    Dim ws As Worksheet, mapWs As Worksheet
    Dim vcol, i As Integer
    Dim icol As Long
    Dim myarr As Variant
    Dim title As String
    Dim titlerow As Integer
    Dim groupDict As Object, reverseDict As Object
    Dim companyName As String, groupName As String
    
    Application.ScreenUpdating = False
    
    ' 初始化字典用于存储公司-分组映射
    Set groupDict = CreateObject("Scripting.Dictionary")
    Set reverseDict = CreateObject("Scripting.Dictionary") ' 分组-公司列表映射
    
    ' 加载分组映射表（假设映射表名为"分组映射表"，A列是公司名，B列是分组名）
    On Error Resume Next
    Set mapWs = ThisWorkbook.Worksheets("分组映射表")
    On Error GoTo 0
    If mapWs Is Nothing Then
        MsgBox "未找到名为'分组映射表'的工作表，请检查！", vbExclamation
        Application.ScreenUpdating = True
        Exit Sub
    End If
    
    ' 读取映射表数据到字典
    Dim mapLr As Long
    mapLr = mapWs.Cells(mapWs.Rows.Count, "A").End(xlUp).Row
    For i = 2 To mapLr
        companyName = Trim(mapWs.Cells(i, "A").Value)
        groupName = Trim(mapWs.Cells(i, "B").Value)
        If companyName <> "" And groupName <> "" Then
            groupDict(companyName) = groupName
            ' 反向存储分组对应的公司列表
            If Not reverseDict.Exists(groupName) Then
                reverseDict(groupName) = Array(companyName)
            Else
                reverseDict(groupName) = Array(reverseDict(groupName), companyName)
                ' 扁平化数组（避免嵌套）
                reverseDict(groupName) = Application.WorksheetFunction.Transpose( _
                    Application.WorksheetFunction.Index(reverseDict(groupName), 0, 0))
            End If
        End If
    Next i
    
    ' 获取用户选择的过滤列
    vcol = Application.InputBox(prompt:="请选择要过滤的列（数字）:", title:="选择过滤列", Default:="2", Type:=1)
    Set ws = ActiveSheet
    lr = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row
    title = "A1"
    titlerow = ws.Range(title).Cells(1).Row
    icol = ws.Columns.Count
    ws.Cells(1, icol) = "分组"
    
    ' 收集所有唯一分组名
    For i = 2 To lr
        companyName = Trim(ws.Cells(i, vcol).Value)
        If companyName <> "" Then
            ' 查找对应的分组名，无映射则用公司名本身
            groupName = IIf(groupDict.Exists(companyName), groupDict(companyName), companyName)
            ' 加入唯一分组列表
            On Error Resume Next
            If Application.WorksheetFunction.Match(groupName, ws.Columns(icol), 0) = 0 Then
                ws.Cells(ws.Rows.Count, icol).End(xlUp).Offset(1) = groupName
            End If
            On Error GoTo 0
        End If
    Next i
    
    ' 转换为数组处理
    myarr = Application.WorksheetFunction.Transpose(ws.Columns(icol).SpecialCells(xlCellTypeConstants))
    ws.Columns(icol).Clear
    
    ' 按分组拆分数据
    For i = 2 To UBound(myarr)
        groupName = myarr(i)
        ' 获取该分组下的所有公司
        Dim filterArr As Variant
        If reverseDict.Exists(groupName) Then
            filterArr = reverseDict(groupName)
        Else
            ' 无映射的分组（即单个公司）
            filterArr = Array(groupName)
        End If
        
        ' 应用筛选
        ws.Range(title).AutoFilter field:=vcol, Criteria1:=filterArr, Operator:=xlFilterValues
        
        ' 创建或定位分组工作表
        Dim targetWs As Worksheet
        On Error Resume Next
        Set targetWs = ThisWorkbook.Worksheets(groupName)
        On Error GoTo 0
        If targetWs Is Nothing Then
            Set targetWs = Sheets.Add(after:=Worksheets(Worksheets.Count))
            targetWs.Name = groupName
            ' 复制表头
            ws.Range("A" & titlerow & ":" & ws.Cells(titlerow, icol - 1).Address).Copy targetWs.Range("A1")
        End If
        
        ' 复制筛选后的行（跳过表头）
        ws.Range("A" & titlerow + 1 & ":A" & lr).SpecialCells(xlCellTypeVisible).EntireRow.Copy _
            targetWs.Cells(targetWs.Rows.Count, "A").End(xlUp).Offset(1)
        
        ' 取消筛选
        ws.AutoFilterMode = False
    Next i
    
    ws.Activate
    Application.ScreenUpdating = True
    MsgBox "数据拆分完成！", vbInformation
End Sub

关键修改说明 #

• 新增字典映射: 使用两个Scripting.Dictionary分别存储公司→分组和分组→公司列表的映射关系，实现快速查找和反向匹配。
• 加载分组映射表: 读取名为分组映射表的工作表数据（A列公司名，B列分组名），自动构建映射关系；如果找不到该表会弹出提示。
• 收集唯一分组: 遍历数据行时，根据映射表将公司名转换为分组名，收集所有唯一的分组作为拆分依据。
• 多条件筛选: 针对每个分组，使用xlFilterValues运算符筛选该分组下的所有公司，实现批量复制。
• 兼容无映射公司: 对于映射表中未列出的公司，直接以公司名作为分组名单独拆分。

使用注意事项 #

1. 确保存在名为分组映射表的工作表，A列是公司全称（需与数据列的公司名完全匹配），B列是对应的分组名。
2. 如果公司名存在空格或特殊字符，需保证映射表中的名称与数据列完全一致。
3. 运行前建议备份原数据，避免意外覆盖。

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