我已经修改了您的代码使用提供的模拟了数据。请对代码进行必要的调整，使其与您的实际数据保持一致。

Sub pasteDate()

    With ActiveSheet
        Dim dt As Range
        Dim indexName As Range
        Dim findRng As Range
        Dim foundCell As Range
        Dim element As Range
        
        ' Constant for the number of rows below the findRng
        Const dataRows = 3 
        
        ' Set the date cell as the target date (I2)
        Set dt = .Range("I2") ' DT value
        
        ' Set the indexName range 
        Set indexName = .Range("H6:K6")
        
        ' Set the findRng to define the data cells only, not the entire area (A2:F2, A6:F6, A10:F10)
        Set findRng = .Range("A2:F2,A6:F6,A10:F10")
        
        ' Loop through each element in the indexName range
        For Each element In indexName

            Set foundCell = findRng.Find(element.Value)
            
            ' Declare variables for the next empty cell and a counter
            Dim nextCell As Range
            Dim r As Integer
            
            If Not foundCell Is Nothing Then
                r = 1
                ' Loop to find the next empty cell within dataRows
                Do While r <= dataRows
                    Set nextCell = foundCell.Offset(r, 0)
                    ' If the next cell is empty, paste the date and exit the loop
                    If IsEmpty(nextCell) Then
                        nextCell = dt
                        Exit Do
                    Else
                        ' If no empty cell is found within dataRows, show a message and exit
                        r = r + 1
                        If r > dataRows Then
                        foundCell.Activate
                        Range(ActiveCell.Offset(2, 0), ActiveCell.Offset(3, 0)).Select
                        Application.CutCopyMode = False
                        Selection.Cut Destination:=foundCell.Offset(1)
                        dt.Copy
                        nextCell.Offset(1) = dt
                        nextCell.Offset(1).Interior.Color = dt.Interior.Color
                            Exit Do 'was Exit For
                        End If
                    End If
                Loop
            End If
        Next element
    End With
End Sub