Excel VBA需求：根据Sheet1列颜色复制行至Sheet2对应表头

嘿，我来帮你搞定这个Excel按单元格颜色自动分类行数据的需求！

首先咱们先明确你给出的分类规则（你可以根据实际情况随时调整）：

• 规则1：Sheet1中A列单元格为红色、B列单元格为黄色 → 复制到Sheet2的「Inefficiencies」表头下方
• 规则2：Sheet1中A列单元格为蓝色、B列单元格无填充颜色 → 复制到Sheet2的「Effective」表头下方
• 规则3：其他颜色组合 → 可复制到第三个自定义表头（比如「Other」）下方

下面是直接可用的VBA代码，我加了详细注释，方便你理解和修改：

Sub CopyRowsByCellColor()
    Dim wsSource As Worksheet, wsTarget As Worksheet
    Dim lastRowSource As Long, lastRowTarget As Long
    Dim i As Long, j As Long
    Dim targetHeaders As Variant
    Dim colorConditions As Variant
    
    ' 指定源表和目标表
    Set wsSource = ThisWorkbook.Sheets("Sheet1")
    Set wsTarget = ThisWorkbook.Sheets("Sheet2")
    
    ' 定义表头名称和对应的颜色规则（一一对应）
    ' 格式：{"表头名", A列颜色值, B列颜色值}
    targetHeaders = Array("Inefficiencies", "Effective", "Other")
    colorConditions = Array( _
        Array(RGB(255, 0, 0), RGB(255, 255, 0)), _ ' 红+黄 → Inefficiencies
        Array(RGB(0, 0, 255), xlNone), _ ' 蓝+无颜色 → Effective
        Array(xlNone, xlNone) _ ' 其他情况 → Other（可自行修改颜色条件）
    )
    
    ' 获取源表最后一行数据的行号
    lastRowSource = wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).Row
    
    ' 遍历源表每一行（从第2行开始，跳过表头）
    For i = 2 To lastRowSource
        ' 检查当前行匹配哪个颜色规则
        For j = LBound(colorConditions) To UBound(colorConditions)
            ' 对比A、B列的颜色是否符合当前规则
            If wsSource.Cells(i, "A").Interior.Color = colorConditions(j)(0) And _
               wsSource.Cells(i, "B").Interior.Color = colorConditions(j)(1) Then
                
                ' 找到目标表中对应表头的位置
                lastRowTarget = wsTarget.Columns("A").Find(What:=targetHeaders(j), LookIn:=xlValues, LookAt:=xlWhole).Row
                
                ' 找到表头下方的第一个空行
                lastRowTarget = wsTarget.Cells(lastRowTarget + 1, "A").End(xlDown).Row + 1
                ' 如果表头下没有数据，直接用表头的下一行
                If lastRowTarget < lastRowTarget + 1 Then lastRowTarget = lastRowTarget + 1
                
                ' 复制源行的A-C列到目标行
                wsSource.Rows(i).Columns("A:C").Copy Destination:=wsTarget.Rows(lastRowTarget)
                
                ' 匹配到规则后跳出循环，不用再检查其他规则
                Exit For
            End If
        Next j
    Next i
    
    ' 弹出完成提示
    MsgBox "数据分类复制完成！", vbInformation
End Sub

使用步骤： #

1. 打开你的Excel文件，按下 Alt + F11 打开VBA编辑器
2. 在左侧「工程资源管理器」中右键点击你的工作簿名称 → 插入 → 模块
3. 将上面的代码粘贴到模块窗口中
4. 根据实际情况修改代码里的颜色值和表头名称（比如你的红色不是标准RGB(255,0,0)，可以用取色工具获取准确的RGB值）
5. 按下 F5 运行代码，或者回到Excel界面，点击「开发工具」→「宏」→ 选择CopyRowsByCellColor执行

额外说明： #

• 确保Sheet2中已经存在对应的三个表头，代码会自动定位表头位置
• 如果单元格颜色是通过条件格式设置的，需要把代码里的.Interior.Color改成.DisplayFormat.Interior.Color，因为条件格式的颜色不会直接存在.Interior.Color属性中
• 要是有更多颜色规则，直接在targetHeaders和colorConditions数组里添加新元素即可，格式和前面保持一致

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