Every second row in color when copying data from Table & Pivot Table in VBA

The following code is supposed to copy data from a Master workbook into separate workbooks.

After copying, the headers in row 1 and 2 are in the style of the source data (which is good).However, the individual rows which follow in row 3 and beyond are not colored.

I want to make every second row from row 3 onwards colored (similarly to the banded row function when creating a table). Like this:

Option ExplicitSub 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 = TrueEnd Sub

This is a follow-up question of this post