VBA实现JobTravSeq列拆分与任务匹配标记技术问询

需求概述 #

• 处理A列（JobTravSeq）指定范围的单元格，按-拆分每个单元格值为三个字段：Job Number、Traveller ID、Sequence No.
• 针对每个拆分出的字段组，定位B列与Job Number匹配且C列与Traveller ID匹配的首尾行（rowStart和rowEnd）
• 在首尾行范围内，标记D列（Sequence No.）与拆分出的Sequence No.匹配的单元格（添加前缀* ）
• 实现辅助过程，弹窗显示所有已标记的任务行信息

优化后代码 #

主处理过程 #

Sub SampleDocOrganise()
    Dim ws As Worksheet
    Dim lastRow As Long, i As Long, rowStart As Long, rowEnd As Long, j As Long
    Dim splitVals As Variant
    Dim targetJob As String, targetTraveller As String, targetSeq As String
    
    ' 指定目标工作表，避免依赖ActiveSheet
    Set ws = ThisWorkbook.Worksheets("Sheet1")
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    
    ' 遍历A列数据行（示例从第4行开始，可根据实际调整）
    For i = 4 To lastRow
        ' 拆分A列值，校验格式有效性
        splitVals = Split(ws.Cells(i, "A").Value, "-")
        If UBound(splitVals) = 2 Then
            targetJob = Trim(splitVals(0))
            targetTraveller = Trim(splitVals(1))
            targetSeq = Trim(splitVals(2))
            
            ' 向上查找首个匹配Job和Traveller的行
            rowStart = 0
            For rowStart = i - 1 To 4 Step -1
                If Trim(ws.Cells(rowStart, "B").Value) = targetJob And _
                   Trim(ws.Cells(rowStart, "C").Value) = targetTraveller Then
                    Exit For
                End If
            Next rowStart
            ' 若向上未找到，从当前行向下查找
            If rowStart < 4 Then
                For rowStart = i To lastRow
                    If Trim(ws.Cells(rowStart, "B").Value) = targetJob And _
                       Trim(ws.Cells(rowStart, "C").Value) = targetTraveller Then
                        Exit For
                    End If
                Next rowStart
            End If
            
            ' 向下查找最后一个匹配Job和Traveller的行
            rowEnd = 0
            For rowEnd = i To lastRow
                If Trim(ws.Cells(rowEnd, "B").Value) <> targetJob Or _
                   Trim(ws.Cells(rowEnd, "C").Value) <> targetTraveller Then
                    rowEnd = rowEnd - 1
                    Exit For
                End If
            Next rowEnd
            ' 若循环至最后一行仍匹配，直接赋值
            If rowEnd = 0 Then rowEnd = lastRow
            
            ' 在匹配范围内标记对应Sequence No.
            If rowStart > 0 And rowEnd >= rowStart Then
                For j = rowStart To rowEnd
                    If Trim(ws.Cells(j, "D").Value) = targetSeq Then
                        ' 避免重复添加标记
                        If Left(ws.Cells(j, "D").Value, 2) <> "* " Then
                            ws.Cells(j, "D").Value = "* " & ws.Cells(j, "D").Value
                            ' 设置标记字体格式（可选）
                            With ws.Cells(j, "D").Characters(Start:=1, Length:=2).Font
                                .Bold = True
                                .Color = RGB(255, 0, 0)
                            End With
                        End If
                    End If
                Next j
            End If
        End If
    Next i
End Sub

任务弹窗过程 #

Sub MsgboxTasks()
    Dim ws As Worksheet
    Dim lastRow As Long, i As Long
    Dim taskList As String
    
    Set ws = ThisWorkbook.Worksheets("Sheet1")
    lastRow = ws.Cells(ws.Rows.Count, "D").End(xlUp).Row
    taskList = "当前标记任务行：" & vbCrLf & vbCrLf
    
    ' 收集所有带标记的任务
    For i = 4 To lastRow
        If Left(ws.Cells(i, "D").Value, 2) = "* " Then
            taskList = taskList & "行" & i & ": " & ws.Cells(i, "B").Value & "-" & _
                       ws.Cells(i, "C").Value & "-" & Mid(ws.Cells(i, "D").Value, 3) & vbCrLf
        End If
    Next i
    
    ' 根据结果弹窗提示
    If taskList = "当前标记任务行：" & vbCrLf & vbCrLf Then
        MsgBox "未找到已标记的任务", vbInformation
    Else
        MsgBox taskList, vbInformation, "当前任务列表"
    End If
End Sub

代码说明 #

1. 范围优化：通过lastRow获取数据边界，避免遍历整列，提升运行效率
2. 格式校验：拆分后检查字段数量，避免格式错误引发的异常
3. 首尾行定位：双向循环查找匹配的首尾行，确保范围准确覆盖目标组
4. 重复防护：检查单元格前缀，避免重复添加标记
5. 视觉区分：可选设置标记字体的加粗和红色，增强辨识度
6. 信息汇总：辅助过程收集并弹窗展示所有标记任务，便于快速查看

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