如何修改VBA代码实现多Excel工作表蓝色字体行批量复制

核心修改思路 #

原代码仅针对单个工作表（580400）处理，要实现批量操作，只需遍历指定的目标工作表集合，对每个工作表重复执行“检查蓝色字体行→复制到Sheet2”的逻辑即可。另外需要注意：如果蓝色字体是通过条件格式设置的，原代码判断Font.Color的方式会失效，需改用DisplayFormat.Font.Color获取实际显示的颜色。

修改后的完整代码 #

Sub CopyColouredFontTransactions()
    Dim targetSheetNames As Variant
    Dim wsName As Variant
    Dim sourceWS As Worksheet
    Dim destWS As Worksheet
    Dim periodField As Range
    Dim periodCell As Range
    Dim lastRow As Long
    
    ' 定义需要处理的工作表名称数组
    targetSheetNames = Array("580400", "580401", "580402", "580403")
    Set destWS = Worksheets("Sheet2")
    
    ' 遍历每个目标工作表
    For Each wsName In targetSheetNames
        Set sourceWS = Worksheets(wsName)
        
        ' 获取A列有数据的范围（避免空表报错）
        lastRow = sourceWS.Cells(sourceWS.Rows.Count, "A").End(xlUp).Row
        If lastRow >= 2 Then
            Set periodField = sourceWS.Range("A2:A" & lastRow)
            
            ' 检查每一行的字体颜色
            For Each periodCell In periodField
                ' 若为条件格式设置的蓝色，改用DisplayFormat.Font.Color
                ' 若为直接设置的字体颜色，保留Font.Color即可
                If periodCell.DisplayFormat.Font.Color = RGB(0, 176, 240) Then
                    ' 复制当前行的前15列到Sheet2的下一行
                    periodCell.Resize(1, 15).Copy _
                        Destination:=destWS.Cells(destWS.Rows.Count, "A").End(xlUp).Offset(1, 0)
                End If
            Next periodCell
        End If
    Next wsName
    
    ' 自动调整Sheet2的列宽
    destWS.Columns.AutoFit
End Sub

关键改动说明 #

• 目标工作表数组：用Array()定义所有需要处理的工作表名称，后续新增表只需在数组中添加即可。
• 空表处理：通过lastRow判断A列是否有数据，避免空表时Range("A2").End(xlDown)选中无效范围导致报错。
• 条件格式适配：使用DisplayFormat.Font.Color获取条件格式设置的显示颜色，确保判断准确。
• 遍历逻辑：外层循环遍历所有目标工作表，内层循环保留原有的行检查与复制逻辑。

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