如何优化含缺失值的数据分组以生成最少子表？

我们需要从含缺失值（缺失数据以红色高亮）的原始表格生成子表，核心目标是基于不同行的缺失列组合，生成数量最少的输出子表，确保始终得到最优解。

现有一段VBA代码可实现该功能，但存在缺陷：当Example20行出现在数据集靠前位置时，代码会为它创建包含缺失列G和I的子表，最终生成5个子表，无法得到仅4个子表的最优解。现在需要优化这段代码，使其无论行顺序如何，都能稳定输出最优解。

Sub GroupDataOptimised()
    Dim ws As Worksheet
    Dim wbNew As Workbook
    Dim wsOutput As Worksheet
    Dim lastRow As Long, lastCol As Long
    Dim currentRow As Long
    Dim col As Integer
    Dim outputRow As Long
    Dim missingKey As String
    Dim dict As Object
    Dim missingDict As Object
    Dim existingKeys As Variant
    Dim headers() As String
    Dim foundSubset As Boolean
    Dim i As Integer, j As Integer
    
    ' 定义输入工作表
    Set ws = ThisWorkbook.Sheets("Missing Data")
    
    ' 创建用于输出的新工作簿
    Set wbNew = Workbooks.Add
    
    ' 初始化用于追踪缺失数据的字典
    Set dict = CreateObject("Scripting.Dictionary")
    Set missingDict = CreateObject("Scripting.Dictionary")
    
    ' 获取输入数据的最后一行和最后一列
    lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
    lastCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
    
    ' 遍历每一行，识别缺失数据模式
    For currentRow = 2 To lastRow
        missingKey = ""
        
        ' 构建代表缺失列的键值
        For col = 3 To lastCol ' 从第3列开始，跳过"Name"和"Code"列
            If ws.Cells(currentRow, col).Value = "" Then
                missingKey = missingKey & ws.Cells(1, col).Value & "|"
            End If
        Next col
        
        ' 如果存在缺失数据
        If missingKey <> "" Then
            foundSubset = False
            existingKeys = dict.Keys
            
            ' 检查所有已有的模式是否存在子集匹配
            For i = 0 To dict.Count - 1
                Dim existingKey As String
                existingKey = existingKeys(i)
                
                ' 检查当前缺失键是否是已有键的子集，反之亦然
                If IsSubset(existingKey, missingKey) Then
                    foundSubset = True
                    ' 将当前行输出到已有的子集工作表
                    Set wsOutput = missingDict(existingKey)
                    outputRow = wsOutput.Cells(wsOutput.Rows.Count, 1).End(xlUp).Row + 1
                    
                    wsOutput.Cells(outputRow, 1).Value = ws.Cells(currentRow, 1).Value ' Name列
                    wsOutput.Cells(outputRow, 2).Value = ws.Cells(currentRow, 2).Value ' Code列
                    
                    ' 填充缺失列为空值
                    headers = Split(existingKey, "|")
                    For j = 0 To UBound(headers) - 1
                        If headers(j) <> "" Then
                            For col = 3 To lastCol
                                If wsOutput.Cells(1, col).Value = headers(j) Then
                                    wsOutput.Cells(outputRow, col).Value = "" ' 缺失列数据设为空
                                End If
                            Next col
                        End If
                    Next j
                End If
            Next i
            
            ' 如果未找到匹配的子集，为当前缺失数据模式创建新表
            If Not foundSubset Then
                dict.Add missingKey, dict.Count + 1
                
                ' 为每个唯一的缺失数据模式创建新工作表
                Set wsOutput = wbNew.Sheets.Add(After:=wbNew.Sheets(wbNew.Sheets.Count))
                wsOutput.Name = "Missing_" & dict.Count
                
                ' 为新工作表添加表头
                wsOutput.Cells(1, 1).Value = "Name"
                wsOutput.Cells(1, 2).Value = "Code"
                
                ' 添加缺失列的列名
                headers = Split(missingKey, "|")
                For col = 0 To UBound(headers) - 1
                    If headers(col) <> "" Then
                        wsOutput.Cells(1, col + 3).Value = headers(col)
                    End If
                Next col
                
                ' 初始化缺失数据字典
                missingDict.Add missingKey, wsOutput
                
                ' 将当前行输出到新工作表
                outputRow = 2
                wsOutput.Cells(outputRow, 1).Value = ws.Cells(currentRow, 1).Value ' Name列
                wsOutput.Cells(outputRow, 2).Value = ws.Cells(currentRow, 2).Value ' Code列
                
                ' 填充缺失列为空值
                For j = 0 To UBound(headers) - 1
                    If headers(j) <> "" Then
                        wsOutput.Cells(outputRow, j + 3).Value = "" ' 缺失列数据设为空
                    End If
                Next j
            End If
        End If
    Next currentRow
    
    ' 调整每个输出工作表的列宽以提升可读性
    For Each wsOutput In wbNew.Sheets
        wsOutput.Cells.EntireColumn.AutoFit
    Next wsOutput
    
    MsgBox "缺失数据已按缺失列分组到新工作簿中！", vbInformation
End Sub

' 检查一个键是否是另一个键的子集的函数
' key1: 以"|"分隔的缺失列名称字符串
' key2: 另一个以"|"分隔的缺失列名称字符串
' 返回值: 如果key1是key2的子集则返回True，否则返回False
Function IsSubset(key1 As String, key2 As String) As Boolean
    ' 声明用于存储从key1和key2中提取的列名数组
    Dim arr1() As String, arr2() As String
    ' 循环变量
    Dim i As Integer, j As Integer
    ' 标记是否找到匹配项
    Dim found As Boolean
    
    ' 使用"|"分隔符将键拆分为列名数组
    arr1 = Split(key1, "|") ' 来自key1的缺失列名称数组
    arr2 = Split(key2, "|") ' 来自key2的缺失列名称数组
    
    ' 如果key1的元素数量多于key2，则不可能是子集
    If UBound(arr1) > UBound(arr2) Then
        ' key1的长度应小于或等于key2才可能是子集
        IsSubset = False
        Exit Function
    End If
    
    ' 遍历arr1中的每个元素（代表key1）
    For i = 0 To UBound(arr1) - 1
        ' 跳过由首尾分隔符导致的空元素
        If arr1(i) <> "" Then
            found = False ' 为arr1中的每个元素重置找到标记
            ' 遍历arr2中的每个元素（代表key2）
            For j = 0 To UBound(arr2) - 1
                ' 如果arr1中的当前元素与arr2中的某个元素匹配
                If arr1(i) = arr2(j) Then
                    found = True ' 设置找到标记为True
                    Exit For ' 无需继续在arr2中查找当前元素
                End If
            Next j
            ' 如果在arr2中未找到arr1的当前元素
            If Not found Then
                IsSubset = False ' key1不是key2的子集
                Exit Function ' 提前退出函数
            End If
        End If
    Next i
    
    ' 如果arr1中的所有元素都能在arr2中找到，则key1是key2的子集
    IsSubset = True
End Function

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