Excel VBA宏优先级提取故障：按D/T/S/M提取2行数据至M列

我在Excel的S列中有一批数据，首字母为D、T、S、M中的一个，需要编写Microsoft VBA代码从中提取仅2行数据到M列，选取规则遵循优先级：D优先级最高，其次是T，然后是S，最后是M。

用ChatGPT生成的代码除优先级逻辑外其他功能均正常，它始终按数据的行顺序而非优先级选取数据。例如当数据顺序为T、M、S、D时，代码会选取T和M这两行，但正确结果应选取D和T；实际运行时，代码仅提取了DDC23和MDC23行，与预期结果不符。

原生成代码 #

Sub Sage_Data_Extraction()

    Dim ws As Worksheet
    Dim lastRow As Long
    Dim cell As Range

    ' Set the worksheet (change Sheet1 to the name of your sheet)
    Set ws = ThisWorkbook.Sheets("Sheet1")

    ' Delete columns T, U, V, W
    ws.Columns("T:W").Delete

    ' Find the last row with data in column S
    lastRow = ws.Cells(ws.Rows.Count, "S").End(xlUp).Row

    ' Loop through each cell in column S (starting from S2)
    For Each cell In ws.Range("S2:S" & lastRow)
        ' Delete "." in the cell value
        cell.Value = Replace(cell.Value, ".", "")

        ' Erase anything after the 5th character
        If Len(cell.Value) > 5 Then
            cell.Value = Left(cell.Value, 5)
        End If
    Next cell

    ' Loop through each cell in column T (starting from T1)
    For Each cell In ws.Range("T1:T" & lastRow)
        ' Delete any characters before "856A"
        Dim position856A As Long
        position856A = InStr(1, cell.Value, "856A")
        If position856A > 0 Then
            cell.Value = Mid(cell.Value, position856A)
        End If
    Next cell

    ' Loop through each cell in column S (starting from S2)
    For Each cell In ws.Range("S2:S" & lastRow)
        Dim destRow As Long
        destRow = cell.Row ' Calculate destination row (4 or 5)

        If destRow >= 4 And destRow <= 5 Then
            Select Case UCase(Left(cell.Value, 1))
                Case "D"
                    ' Copy values from Columns S, U, and X to Columns M, N, and O
                    ws.Cells(destRow, "M").Value = ws.Cells(cell.Row, "S").Value
                    ws.Cells(destRow, "N").Value = ws.Cells(cell.Row, "U").Value
                    
                    ' Check if Column V contains "EUR" and multiply the value in Column N by 1.1
                    If InStr(1, UCase(ws.Cells(cell.Row, "V").Value), "EUR") > 0 Then
                        ws.Cells(destRow, "N").Value = ws.Cells(destRow, "N").Value * 1.1
                    End If
                    
                    ws.Cells(destRow, "O").Value = ws.Cells(cell.Row, "X").Value
                
                Case "T"
                    ' Copy values from Columns S, U, and X to Columns M, N, and O if the current value in M is not "D"
                    If UCase(ws.Cells(destRow, "M").Value) <> "D" Then
                        ws.Cells(destRow, "M").Value = ws.Cells(cell.Row, "S").Value
                        ws.Cells(destRow, "N").Value = ws.Cells(cell.Row, "U").Value
                        
                        ' Check if Column V contains "EUR" and multiply the value in Column N by 1.1
                        If InStr(1, UCase(ws.Cells(cell.Row, "V").Value), "EUR") > 0 Then
                            ws.Cells(destRow, "N").Value = ws.Cells(destRow, "N").Value * 1.1
                        End If
                        
                        ws.Cells(destRow, "O").Value = ws.Cells(cell.Row, "X").Value
                    End If
                
                Case "S"
                    ' Copy values from Columns S, U, and X to Columns M, N, and O if the current value in M is neither "D" nor "T"
                    If UCase(ws.Cells(destRow, "M").Value) <> "D" And UCase(ws.Cells(destRow, "M").Value) <> "T" Then
                        ws.Cells(destRow, "M").Value = ws.Cells(cell.Row, "S").Value
                        ws.Cells(destRow, "N").Value = ws.Cells(cell.Row, "U").Value
                        
                        ' Check if Column V contains "EUR" and multiply the value in Column N by 1.1
                        If InStr(1, UCase(ws.Cells(cell.Row, "V").Value), "EUR") > 0 Then
                            ws.Cells(destRow, "N").Value = ws.Cells(destRow, "N").Value * 1.1
                        End If
                        
                        ws.Cells(destRow, "O").Value = ws.Cells(cell.Row, "X").Value
                    End If
                
                Case "M"
                    ' Copy values from Columns S, U, and X to Columns M, N, and O if the current value in M is neither "D", "T", nor "S"
                    If UCase(ws.Cells(destRow, "M").Value) <> "D" And UCase(ws.Cells(destRow, "M").Value) <> "T" And UCase(ws.Cells(destRow, "M").Value) <> "S" Then
                        ws.Cells(destRow, "M").Value = ws.Cells(cell.Row, "S").Value
                        ws.Cells(destRow, "N").Value = ws.Cells(cell.Row, "U").Value
                        
                        ' Check if Column V contains "EUR" and multiply the value in Column N by 1.1
                        If InStr(1, UCase(ws.Cells(cell.Row, "V").Value), "EUR") > 0 Then
                            ws.Cells(destRow, "N").Value = ws.Cells(destRow, "N").Value * 1.1
                        End If
                        
                        ws.Cells(destRow, "O").Value = ws.Cells(cell.Row, "X").Value
                    End If
            End Select
        End If
    Next cell
End Sub

问题分析 #

原代码的核心缺陷：

• 错误将目标行destRow绑定为当前遍历的行号，仅处理第4、5行的数据，而非全量筛选后选取
• 按行顺序遍历处理，高优先级数据如果出现在后面，无法覆盖低优先级的已选数据
• 逻辑上没有先收集所有数据再按优先级排序筛选，导致优先级规则失效

修正后的代码 #

Sub Sage_Data_Extraction_Fixed()
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim cell As Range
    Dim priorityGroups As Object
    Dim destRow As Long
    Dim groupKey As Variant
    Dim count As Integer
    
    ' 初始化字典存储各优先级组的数据行
    Set priorityGroups = CreateObject("Scripting.Dictionary")
    priorityGroups.Add "D", New Collection
    priorityGroups.Add "T", New Collection
    priorityGroups.Add "S", New Collection
    priorityGroups.Add "M", New Collection
    
    ' 设置工作表
    Set ws = ThisWorkbook.Sheets("Sheet1")
    
    ' 删除指定列（保留原逻辑）
    ws.Columns("T:W").Delete
    
    ' 获取S列最后一行
    lastRow = ws.Cells(ws.Rows.Count, "S").End(xlUp).Row
    
    ' 清洗S列数据（保留原逻辑）
    For Each cell In ws.Range("S2:S" & lastRow)
        cell.Value = Replace(cell.Value, ".", "")
        If Len(cell.Value) > 5 Then
            cell.Value = Left(cell.Value, 5)
        End If
        ' 根据首字母将行号加入对应优先级集合
        priorityGroups(UCase(Left(cell.Value, 1))).Add cell.Row
    Next cell
    
    ' 清洗T列数据（保留原逻辑）
    For Each cell In ws.Range("T1:T" & lastRow)
        Dim position856A As Long
        position856A = InStr(1, cell.Value, "856A")
        If position856A > 0 Then
            cell.Value = Mid(cell.Value, position856A)
        End If
    Next cell
    
    ' 清空目标区域M:O的原有数据
    ws.Range("M4:O5").ClearContents
    
    ' 按优先级顺序填充前2行数据
    destRow = 4
    count = 0
    For Each groupKey In Array("D", "T", "S", "M")
        If count >= 2 Then Exit For
        ' 遍历当前优先级组的行
        For Each rowNum In priorityGroups(groupKey)
            If count >= 2 Then Exit For
            ' 复制S、U、X列数据到M、N、O列
            ws.Cells(destRow, "M").Value = ws.Cells(rowNum, "S").Value
            ws.Cells(destRow, "N").Value = ws.Cells(rowNum, "U").Value
            
            ' EUR汇率换算（保留原逻辑）
            If InStr(1, UCase(ws.Cells(rowNum, "V").Value), "EUR") > 0 Then
                ws.Cells(destRow, "N").Value = ws.Cells(destRow, "N").Value * 1.1
            End If
            
            ws.Cells(destRow, "O").Value = ws.Cells(rowNum, "X").Value
            
            destRow = destRow + 1
            count = count + 1
        Next rowNum
    Next groupKey
End Sub

修正说明 #

1. 使用字典+集合按优先级分类存储所有符合条件的行号，确保高优先级数据优先被处理
2. 先清空目标区域，避免原有数据干扰结果
3. 按D→T→S→M的优先级顺序，依次从对应组中取数据，直到填满2行
4. 完整保留原代码中对S列、T列的数据清洗逻辑，以及EUR汇率换算规则

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