遍历工作表，并在所有其他工作表上仅应用一组条件格式

问：

如何仅将一张纸的条件格式传输到所有其他工作表？xlPaste 和 xlPasteAllMergingConditionalFormats 等的任何技巧都不起作用，因为我的代码是通过字典复制范围的。

 Sub LoopSheets()

        
 Dim ws As Worksheet

         For Each ws In Worksheets

            ' Loop through all sheets after sheet 1, and Copy ONLY the conditional formatting rules from sheet 1 to the others.
            
            

         Next

      End Sub

代码不是我写的，但我从这个网站上的某个人那里得到了很多帮助。我尽力去理解它。我标记了我的一些想法。

Option Explicit

Sub ExtractCompanyData_NoComp()
    
    ' Define constants.
    
    Const SRC_SHEET_NAME As String = "MasterTable"
    Const DATA_COLUMNS As String = "A:K"
    Const DATE_COLUMN As Long = 6
'   Const COMPANY_COLUMN As Long = 8
    Const DST_FIRST_CELL As String = "A1"
    Const DST_DATE_FORMAT As String = "dd\/mm\/yyyy"
    Const DST_SHEET_NAME_DATE_FORMAT As String = "ddd dd.mm.yyyy"
    Const COPY_HEADERS As Boolean = True
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    ' Return the source data in an array ('sData').
    
    Dim sws As Worksheet: Set sws = wb.Sheets(SRC_SHEET_NAME)
    Dim srg As Range: Set srg = sws.UsedRange.Columns(DATA_COLUMNS)
    Dim srCount As Long: srCount = srg.Rows.Count
    Dim cCount As Long: cCount = srg.Columns.Count
    Dim sData() As Variant: sData = srg.Value
    
    ' An Incomplete Description of the Dictionary and the Collection
    ' A dictionary consists of two arrays: one is called 'Keys' and the other
    ' is called 'Items' ('Values'). Each key has an associated item
    ' and they form a so-called 'key-value pair'.
    ' Each key needs to be unique while its item can hold various data types,
    ' in this case, a collection ('object').
    ' A collection is similar but simpler.
    ' Each of a collection's 'item' needs to be unique.
    ' The collection is used because it is more efficient and you can simply
    ' add just an item to it while you need to add a value pair to a dictionary.
    
    ' Return the unique dates ('sDate') from the source array ('sData')
    ' in the 'keys' of a dictionary.
    ' Each key's corresponding 'item' will hold a collection whose 'items'
    ' will hold the rows ('sr') where each date ('sDate', key) was found.
    
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    
    Dim sDate As Variant, sr As Long
    
    For sr = 2 To srCount ' skip headers
        sDate = sData(sr, DATE_COLUMN)
        If IsDate(sDate) Then
            If Not dict.Exists(sDate) Then
                ' Create the 'sDate' key in the dictionary
                ' and add a new collection to the key's associated item.
                dict.Add sDate, New Collection
                ' or:
                'Set dict(sDate) = New Collection
            End If
            dict(sDate).Add sr ' add the row to the items of the collection
        End If
    Next sr

    ' Loop through the keys (dates) of the dictionary, and by applying
    ' the required logic, copy the data to the destination worksheet.

    Application.ScreenUpdating = False

    Dim dws As Worksheet, drg As Range, ddrg As Range
    Dim dData() As Variant, sRow As Variant
    Dim dr As Long, idr As Long, drCount As Long, c As Long
    Dim dwsName As String
'   Dim Company As String, IsCompanyFound As Boolean
    
    ' Loop through the keys (dates) of the dictionary.
    For Each sDate In dict.Keys
        
        ' Define the destination array.
        drCount = dict(sDate).Count - COPY_HEADERS
        ReDim dData(1 To drCount, 1 To cCount)
        
        ' Write the headers to the destination array.
        ' Also, determine the used destination array rows ('idr', 'dr')
        ' i.e. the inital row, the first row to be written to minus one.
        If COPY_HEADERS Then
            For c = 1 To cCount
                dData(1, c) = sData(1, c)
            Next c
            idr = 1
        Else
            idr = 0
        End If
        dr = idr
        
        ' Loop through the items ('sRow') of the collection ('dict(sDate)'),
        ' held by the current key's ('dDate') corresponding item ('dict(sDate)'),
        ' and write the values from each corresponding row ('sRow')
        ' of the source array ('sData') to the next row ('dr')
        ' of destination array ('dData') skipping the company column.
        ' Also, attempt to determine the company name.
        For Each sRow In dict(sDate)
            dr = dr + 1
            For c = 1 To cCount
                    dData(dr, c) = sData(sRow, c)
            Next c
        Next sRow

        
        ' Determine the destination worksheet name ('dwsName').
        dwsName = Format(sDate, DST_SHEET_NAME_DATE_FORMAT)
        
        ' Delete an existing same named sheet.
        Application.DisplayAlerts = False
            On Error Resume Next
                wb.Sheets(dwsName).Delete
            On Error GoTo 0
        Application.DisplayAlerts = True
        
        ' Add a new worksheet ('dws') and rename it accordingly.
        'insert right after all sheets
        Set dws = wb.Sheets.Add(After:=wb.Sheets(wb.Sheets.Count))
        
        
        ' Copy the values from the destination array ('dData')
        ' to the destination range ('drg').
        Set drg = dws.Range(DST_FIRST_CELL).Resize(drCount, cCount)
        drg.Value = dData
        
        ' Apply formatting to the destination (range, worksheet).
        With drg
            ' Format headers and reference the destination data range ('ddrg').
            If COPY_HEADERS Then
                With .Rows(1)
                    .Font.Bold = True
                End With
                Set ddrg = drg.Resize(drCount - 1).Offset(1)
            Else
                Set ddrg = drg
            End If
            ' Format the destination data range ('ddrg').
            With ddrg
                ' Format the destination date column.
                With ddrg.Columns(DATE_COLUMN)
                    .NumberFormat = DST_DATE_FORMAT
                End With
            End With
            ' Format the entire destination columns.
            .EntireColumn.AutoFit

       
'XYZ        'Copy Name to Header, delete second row
            .dws.Range("E1") = .dws.Range("E2")
            .Rows(2).EntireRow.Delete
'XYZ

    End With
        
    Next sDate
    
    'Additional Ideas
    
    'sws.Activate
    wb.Save

    Application.ScreenUpdating = True
    
    ' Inform.
    
    MsgBox "Daten wurden extrahiert", vbInformation
    
End Sub

标有“XYZ”的部分： 这没有用。我可以使用 .单元格（“E1”）。价值？ 我该如何推断自己，范围是否可以使用 .cells 或 .value，我真的必须每次都自己尝试一下吗？