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

Question

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 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

This is a follow-up question of this post

Answer 1

• Call CreateTab to format the output table after copy

Sub CreateTab(r As Range)
    Dim oTab As ListObject
    Set r = r.Resize(r.Rows.Count - 1).Offset(1)
    r.ClearFormats
    Set oTab = r.Parent.ListObjects.Add(xlSrcRange, r, , xlYes)
    oTab.TableStyle = "TableStyleMedium8" ' modify as needed
End Sub

Sub Test()
    CreateTab Range("a1").CurrentRegion
End Sub