Каждая вторая строка цветная при копировании данных из таблицы и сводной таблицы в VBA

Следующий код предназначен для копирования данных из главной книги в отдельные книги.

После копирования заголовки в строке 1 и 2 имеют стиль исходных данных (и это хорошо). Однако отдельные строки, следующие за строкой 3 и далее, не окрашены.

Я хочу сделать каждую вторую строку, начиная с третьей, цветной (аналогично функции полосовой строки при создании таблицы). Так:

Option Explicit

Sub copy_data()
    
    Dim count_col As Long
    Dim count_row As Long
    Dim RelationSheet As Worksheet
    Dim AccountSheet As Worksheet
    Dim InstructionSheet As Worksheet
    Dim wb1 As Workbook
    Dim wb2 As Workbook, sht As Worksheet
    Dim desk As String
    Dim START_CELL As String
    
    Dim rngLookUp As Range, 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
    
'   LOAD LOOKUP TABLE INTO AN ARRAY

    With InstructionSheet.Range("R1").CurrentRegion
        arrData = .Resize(.Rows.Count - 1).Offset(1).Value
    End With

'   *******************************************************
    
    Application.ScreenUpdating = False
    
    START_CELL = "B5"
    
'   LOOP THROUGH LOOKUP TABLE

    For i = LBound(arrData) To UBound(arrData)
        sDesk = arrData(i, 1)
        If sDesk = desk Then ' match desk
            sPerson = arrData(i, 2)
            ' report workbook name
            'sFile = Replace(sDesk, " ", "_") & "_" & sPerson & ".xlsx"
            sFile = Format(Date, "yyyymmdd") & & sDesk & "_" & sPerson & ".xlsx"
            Set wb2 = Workbooks.Add
            
            ' add a new sheet for RelationLevel / CODE FOR PIVOT TABLE
            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
            ActiveSheet.UsedRange.EntireColumn.AutoFit
            
            ' add a new sheet for RelationLevel / Not working currently
            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
            ActiveSheet.UsedRange.EntireColumn.AutoFit
            
            Application.DisplayAlerts = False
            ' save report, overwrite if exists
            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

Это дополнительный вопрос к этому посту