从 VBA 中的表和数据透视表复制数据时每隔一行显示颜色

Question

以下代码应该将数据从主工作簿复制到单独的工作簿中。

复制后，第1行和第2行的标题采用源数据的样式（这很好）。 但是，第 3 行及之后的各行没有着色。

我想让从第 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

这是这篇文章

的后续问题

Answer 1

• 复制后调用

  CreateTab

  格式化输出表

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