VBA复制表格/数据透视表时，如何从第3行起实现隔行上色？

现有VBA代码可将主工作簿数据复制到独立工作簿，复制后前两行表头格式保留符合预期，但第3行及之后的行未上色，需求是从第3行开始实现类似表格带纹行的隔行上色效果。

以下是修改后的完整代码：

Option Explicit

Sub copy_data()
    
    Dim RelationSheet As Worksheet
    Dim AccountSheet As Worksheet
    Dim InstructionSheet As Worksheet
    Dim wb2 As Workbook, sht As Worksheet
    Dim desk As String
    Dim START_CELL As String
    
    Dim i As Long, sDesk As String, sPerson As String
    Dim arrData, sFile As String, sPath As String
    
    sPath = ThisWorkbook.Path & "\"
 
    Set InstructionSheet = Sheet15
    Set RelationSheet = Sheet2
    Set AccountSheet = Sheet3
    desk = InstructionSheet.Cells(14, 3).Text
    If Len(desk) = 0 Then Exit Sub
    
    ' 加载查找表到数组
    With InstructionSheet.Range("R1").CurrentRegion
        arrData = .Resize(.Rows.Count - 1).Offset(1).Value
    End With
    
    Application.ScreenUpdating = False
    
    START_CELL = "B5"
    
    ' 遍历查找表
    For i = LBound(arrData) To UBound(arrData)
        sDesk = arrData(i, 1)
        If sDesk = desk Then ' 匹配desk
            sPerson = arrData(i, 2)
            ' 生成报告文件名（修复原代码语法错误）
            sFile = Format(Date, "yyyymmdd") & sDesk & "_" & sPerson & ".xlsx"
            Set wb2 = Workbooks.Add
            
            ' 复制RelationSheet数据到新工作表
            Set sht = ActiveSheet
            sht.Name = RelationSheet.Name
            With RelationSheet.Range(START_CELL)
                .AutoFilter Field:=4, Criteria1:=sDesk
                .AutoFilter Field:=2, Criteria1:=sPerson
                .CurrentRegion.SpecialCells(xlCellTypeVisible).Copy sht.Range("A1")
            End With
            
            ' 冻结窗格
            With ActiveWindow
                If .FreezePanes Then .FreezePanes = False
                .SplitColumn = 1
                .SplitRow = 2
                .FreezePanes = True
            End With
            sht.UsedRange.EntireColumn.AutoFit
            ' 应用隔行上色格式
            ApplyAlternateRowColor sht
            
            ' 复制AccountSheet数据到新工作表
            Set sht = wb2.Sheets.Add
            sht.Name = AccountSheet.Name
            With AccountSheet.Range(START_CELL)
                .AutoFilter Field:=5, Criteria1:=sDesk
                .AutoFilter Field:=2, Criteria1:=sPerson
                .CurrentRegion.SpecialCells(xlCellTypeVisible).Copy sht.Range("A1")
            End With
            
            ' 冻结窗格
            With ActiveWindow
                If .FreezePanes Then .FreezePanes = False
                .SplitColumn = 1
                .SplitRow = 2
                .FreezePanes = True
            End With
            sht.UsedRange.EntireColumn.AutoFit
            ' 应用隔行上色格式
            ApplyAlternateRowColor sht
            
            ' 保存并关闭工作簿
            Application.DisplayAlerts = False
            wb2.SaveAs sPath & sFile
            Application.DisplayAlerts = True
            wb2.Close

            Application.CutCopyMode = False
            RelationSheet.ShowAllData
            RelationSheet.AutoFilterMode = False
        End If
    Next i
    Application.ScreenUpdating = True
End Sub

' 给工作表从第3行开始设置隔行上色条件格式
Sub ApplyAlternateRowColor(targetSht As Worksheet)
    Dim dataRange As Range
    ' 获取数据区域（从第3行到最后一行）
    With targetSht
        Set dataRange = .Range("A3", .Cells(.UsedRange.Row + .UsedRange.Rows.Count - 1, .UsedRange.Column + .UsedRange.Columns.Count - 1))
    End With
    
    ' 清除已有条件格式
    dataRange.FormatConditions.Delete
    
    ' 添加条件格式：奇数行（相对于数据区域起始行）上色
    With dataRange.FormatConditions.Add(Type:=xlExpression, Formula1:="=MOD(ROW()-2,2)=1")
        .Interior.Color = RGB(242, 242, 242) ' 浅灰色，可根据需求修改颜色
    End With
End Sub

关键修改说明： #

• 修复了文件名拼接处的语法错误（原代码中Format(Date, "yyyymmdd") && sDesk多了一个&）
• 新增ApplyAlternateRowColor子过程，通过条件格式实现隔行上色，相比手动设置单元格格式，条件格式能自动适配数据区域变化，更灵活
• 在每个工作表完成数据复制、列宽调整后，调用ApplyAlternateRowColor方法，给第3行及以后的行添加隔行上色效果
• 颜色可通过修改RGB(242,242,242)自行调整，替换为所需的RGB值即可

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