如何筛选各Part Name最高Issue Number及对应最高Sequence Number并导出

需求说明 #

现有三列数据：Part Name、Issue Number、Sequence Number，需完成以下操作：

• 对每个Part Name，筛选出最高的Issue Number
• 在该Issue Number下，提取最高的Sequence Number
• 将每个Part Name的结果导出到独立的Excel工作表

原数据示例 #

原代码问题分析 #

提供的VBA代码存在核心问题：

• 写入工作表时，重复写入了该Part Name的所有原始行，而非仅保留目标结果行
• 循环遍历单元格的方式效率低下，数据量大时卡顿明显
• 未处理数据为空或非数值的边界情况

修正后的VBA代码 #

Sub ExtractMaxIssueAndSequence()
    Dim sourceWs As Worksheet
    Dim lastRow As Long
    Dim dataArr As Variant
    Dim partDict As Object
    Dim partKey As Variant
    Dim currentPart As String
    Dim currentIssue As Double
    Dim currentSeq As Double
    Dim maxIssue As Double
    Dim maxSeq As Double
    Dim newWs As Worksheet
    Dim sheetName As String
    
    ' 设置数据源工作表（可修改为指定工作表名称，如Sheets("原始数据")）
    Set sourceWs = ActiveSheet
    lastRow = sourceWs.Cells(sourceWs.Rows.Count, "A").End(xlUp).Row
    ' 将数据读取到数组，提升处理效率
    dataArr = sourceWs.Range("A1:C" & lastRow).Value
    
    ' 创建字典存储每个Part的最高Issue及对应最高Sequence
    Set partDict = CreateObject("Scripting.Dictionary")
    
    ' 遍历数据数组（从第2行开始，跳过表头）
    For i = 2 To UBound(dataArr)
        currentPart = dataArr(i, 1)
        currentIssue = Val(dataArr(i, 2))
        currentSeq = Val(dataArr(i, 3))
        
        ' 如果是新的Part Name，初始化最大值
        If Not partDict.Exists(currentPart) Then
            partDict.Add currentPart, Array(currentIssue, currentSeq)
        Else
            ' 获取当前存储的最大值
            maxIssue = partDict(currentPart)(0)
            maxSeq = partDict(currentPart)(1)
            
            ' 比较Issue Number
            If currentIssue > maxIssue Then
                ' 新的最高Issue，更新对应的Sequence
                partDict(currentPart) = Array(currentIssue, currentSeq)
            ElseIf currentIssue = maxIssue Then
                ' 相同Issue，比较Sequence Number
                If currentSeq > maxSeq Then
                    partDict(currentPart)(1) = currentSeq
                End If
            End If
        End If
    Next i
    
    ' 关闭屏幕刷新，提升运行速度
    Application.ScreenUpdating = False
    
    ' 为每个Part创建工作表并写入结果
    For Each partKey In partDict.Keys
        ' 处理工作表名称，避免非法字符
        sheetName = Left(WorksheetFunction.Clean(CStr(partKey)), 31)
        sheetName = Replace(sheetName, "\", "_")
        sheetName = Replace(sheetName, "/", "_")
        sheetName = Replace(sheetName, "?", "_")
        sheetName = Replace(sheetName, "*", "_")
        sheetName = Replace(sheetName, "[", "_")
        sheetName = Replace(sheetName, "]", "_")
        
        ' 检查工作表是否已存在
        On Error Resume Next
        Set newWs = ThisWorkbook.Sheets(sheetName)
        On Error GoTo 0
        
        ' 不存在则新建
        If newWs Is Nothing Then
            Set newWs = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
            newWs.Name = sheetName
        End If
        
        ' 写入表头
        newWs.Range("A1:C1").Value = Array("Part Name", "Max Issue Number", "Max Sequence Number")
        ' 写入结果行
        newWs.Range("A2:C2").Value = Array(partKey, partDict(partKey)(0), partDict(partKey)(1))
        
        ' 自动调整列宽
        newWs.Columns("A:C").AutoFit
        Set newWs = Nothing
    Next partKey
    
    Application.ScreenUpdating = True
    MsgBox "数据处理完成！", vbInformation
End Sub

代码说明 #

• 高效数据读取：将数据一次性读入数组，避免频繁操作单元格，大幅提升处理速度
• 字典存储逻辑：通过字典直接记录每个Part的最高Issue及对应Sequence，一次遍历即可完成计算
• 工作表处理：自动处理非法工作表名称，避免命名错误；若工作表已存在则直接覆盖结果
• 边界处理：使用Val()函数将非数值内容转为0，避免空值或文本导致的计算错误

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