如何复制红色字体单元格而非整行？Excel VBA代码优化需求

当前使用的VBA代码仅在整行文本均为红色字体时正常运行，需要调整代码实现以下需求：

• 仅复制红色字体的单元格（而非整行）到新工作表的对应位置
• 同时将对应行A列的代码值复制到新工作表

原代码 #

Sub CopyColouredFontTransactions()

    Dim TransIDField As Range
    Dim TransIDCell As Range
    Dim ATransWS As Worksheet
    Dim HTransWS As Worksheet
    Dim x As Long
    
    Set ATransWS = Worksheets("All Transactions")
    Set TransIDField = ATransWS.Range("A2", ATransWS.Range("A2").End(xlDown))
    Set HTransWS = Worksheets("Highlighted Transactions")
    
    For Each TransIDCell In TransIDField
    
        If TransIDCell.Font.Color = RGB(255, 0, 0) Then
           
            TransIDCell.Resize(1, 10).Copy Destination:= _
                HTransWS.Range("A1").Offset(HTransWS.Rows.Count - 1, 0).End(xlUp).Offset(1, 0)
               
        End If
    
    Next TransIDCell
    
    HTransWS.Columns.AutoFit

End Sub 

修改后的代码 #

Sub CopyRedFontCellsWithID()
    Dim ATransWS As Worksheet
    Dim HTransWS As Worksheet
    Dim lastRow As Long
    Dim lastCol As Long
    Dim targetRow As Long
    Dim i As Long, j As Long
    
    ' 定义工作表对象
    Set ATransWS = Worksheets("All Transactions")
    Set HTransWS = Worksheets("Highlighted Transactions")
    
    ' 获取源表的最后一行和最后一列
    lastRow = ATransWS.Cells(ATransWS.Rows.Count, "A").End(xlUp).Row
    lastCol = ATransWS.Cells(2, ATransWS.Columns.Count).End(xlToLeft).Column
    
    ' 初始化目标表的起始行（从第二行开始，第一行假设是表头）
    targetRow = HTransWS.Cells(HTransWS.Rows.Count, "A").End(xlUp).Row + 1
    
    ' 遍历源表的每一行（从第二行开始）
    For i = 2 To lastRow
        ' 先复制当前行A列的ID到目标表对应行的A列
        HTransWS.Cells(targetRow, "A").Value = ATransWS.Cells(i, "A").Value
        
        ' 遍历当前行的每个单元格（从B列开始，因为A列已经复制ID）
        For j = 2 To lastCol
            ' 检查单元格字体是否为红色
            If ATransWS.Cells(i, j).Font.Color = RGB(255, 0, 0) Then
                ' 复制红色字体单元格的值到目标表对应位置
                HTransWS.Cells(targetRow, j).Value = ATransWS.Cells(i, j).Value
            End If
        Next j
        
        ' 目标行下移，处理下一行数据
        targetRow = targetRow + 1
    Next i
    
    ' 自动调整目标表列宽
    HTransWS.Columns.AutoFit
End Sub

代码说明 #

1. 先获取源表的有效数据范围（最后一行和最后一列），避免遍历空单元格
2. 遍历每一行时，先把A列的ID复制到目标表的对应行A列
3. 逐单元格检查字体颜色，仅复制红色字体的单元格内容到目标表的对应列位置
4. 处理完一行后，目标行自动下移，保证数据对应排列

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