请求修正匹配唯一Code的VBA单元格查找子程序

我来帮你搞定这个Excel数据匹配的问题！先明确你的数据场景：你有两列数据，Code行（比如A、B所在行）的第二列有值，而其下方的答案行（比如1、2、9、3所在行）第二列为空，需要把每个Code和对应的所有答案一一对应起来。你的数据结构大概是这样的：

下面是修正后的VBA子程序，完全贴合你的需求，我会逐段解释逻辑：

Sub MapCodesToAnswers()
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim currentCode As String
    Dim i As Long
    Dim resultRow As Long
    
    ' 替换成你实际要处理的工作表名称
    Set ws = ThisWorkbook.Worksheets("Sheet1")
    ' 获取列A的最后一行数据，避免遍历空行
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    ' 结果输出的起始行，这里默认从第2行开始（第1行可以加表头）
    resultRow = 1
    
    ' 遍历所有数据行
    For i = 1 To lastRow
        ' 判断当前行是否为Code行：第二列有非空值
        If ws.Cells(i, "B").Value <> "" Then
            currentCode = ws.Cells(i, "A").Value
            resultRow = resultRow + 1
            ' 将Code输出到结果区域的C列，可自行调整列位置
            ws.Cells(resultRow, "C").Value = currentCode
            
            ' 开始收集当前Code对应的所有答案
            Dim j As Long
            j = i + 1
            ' 循环直到遇到下一个Code行，或者到达数据末尾
            Do While j <= lastRow And ws.Cells(j, "B").Value = ""
                resultRow = resultRow + 1
                ' Code列留空，仅在D列输出答案值
                ws.Cells(resultRow, "C").Value = ""
                ws.Cells(resultRow, "D").Value = ws.Cells(j, "A").Value
                j = j + 1
            Loop
            ' 跳过已经处理过的答案行，提升遍历效率
            i = j - 1
        End If
    Next i
    
    MsgBox "Code与答案匹配完成！", vbInformation
End Sub

代码关键点说明： #

• 工作表指定：第一行Set ws = ...要替换成你实际的工作表名称，比如"数据 sheet"
• 判断逻辑：用ws.Cells(i, "B").Value <> ""精准识别Code行，完全符合你说的"Code行下一列有值，答案行下一列无值"的规则
• 答案收集：遇到Code行后，用Do While循环自动收集后续所有答案行，直到下一个Code行出现
• 结果输出：默认把Code放到C列，对应答案放到D列，你可以根据需求修改列号（比如改成"E"、"F"）
• 效率优化：i = j - 1会跳过已经处理过的答案行，避免重复遍历，处理大数据量时更高效

额外提示： #

• 如果需要把结果输出到全新的工作表，可以添加Set ws = ThisWorkbook.Worksheets.Add来新建工作表存放结果
• 确保你的数据没有混合行（比如答案行突然出现列B有值的情况），否则会影响判断逻辑

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