如果另外 10 个触摸单元格具有相同的值，则更改单元格颜色 [关闭]答案

【问题标题】：Changing cell color if 10 more touching cells have the same value [closed]如果另外 10 个触摸单元格具有相同的值，则更改单元格颜色 [关闭]
【发布时间】：2018-09-02 08:53:05
【问题描述】：

我有一个包含 X 和 O 的 Excel 电子表格，如果在整行的任何给定位置有十个或更多单元格彼此相邻，我需要更改单元格颜色。

例子：

XXXXXXOOOOOOOOOOOOOOOOOOXX

XOXXXXOOXXOOXXXXXXXXXXXXXXX

OOOXXXXOOOOXXXOOOOOOOOOOOO

在第一行中，我需要所有 17 个 O 来更改它们的单元格颜色，因为它彼此相邻 10 个或更多。第 2 行和第 3 行以此类推...

我不知道如何解决这个问题..

编辑我道歉。我试图简化我的请求，但也许我应该把它全部放在那里。我有 14 个不同的变量可以在单元格中。 D，FA，FD，FI，I，J，L，M，O，P，T，U，V，X。如果除了 X 和 T 之外的任何一个在同一行中彼此相邻 10 次或更多次，我需要将 Interior.Color 更改为红色。

再次道歉。刚开始使用 stackoverflow。

【问题讨论】：

每个 X 或 O 都在自己的单元格中吗？到目前为止，您尝试过什么？
是的，每个 X 或 O 都在自己的单元格中。
我不知道该怎么做。我想知道是否应该制作一个 X 和 O 范围并使用 Intersect 进行测试。但这只会限制我在测试范围内输入的 X 或 O 的数量。

标签： excel vba

【解决方案1】：

使用条件格式代替 vba：

使用此公式为 A:Y 列创建新规则：

=AND(A1<>"",IFERROR(AGGREGATE(15,6,COLUMN(A1:$Y1)/(A1:$Y1=IF(A1="X","O","X")),1),COLUMN($Y1))-IFERROR(AGGREGATE(14,6,COLUMN($A1:A1)/($A1:A1=IF(A1="X","O","X")),1),COLUMN($A1))>=10)

【讨论】：

【解决方案2】：

只是为了好玩而拍了一张……

Sub XsandOs()

Dim lastrow As Long, lastcol As Long, xcounter As Long, ocounter As Long

lastrow = ActiveSheet.Cells(ActiveSheet.Rows.Count, "A").End(xlUp).Row
lastcol = ActiveSheet.Cells(1, ActiveSheet.Columns.Count).End(xlToLeft).Column

For i = 1 To lastrow
    For j = 1 To lastcol
        If Cells(i, j).Value = "x" Then
            xcounter = xcounter + 1
            If j = lastcol Then xcounter = 0
            ocounter = 0
            If xcounter = 10 Then
                Range(Cells(i, j - 9), Cells(i, j)).Interior.Color = vbRed
            End If
        ElseIf Cells(i, j).Value = "o" Then
            ocounter = ocounter + 1
            If j = lastcol Then ocounter = 0
            xcounter = 0
            If ocounter = 10 Then
                Range(Cells(i, j - 9), Cells(i, j)).Interior.Color = vbRed
            End If
        End If
    Next j
Next i

End Sub

【讨论】：

【解决方案3】：

@ScottCraner 解决方案绝对是首选，但我喜欢我的 VBA 解决方案，所以我将它加入其中。

代码假定您只有 X 和 O，但会为任何 10 或更多的重复值着色。

Public Sub Test()

    Dim rLastCell As Range
    Dim rCell As Range
    Dim rFirstCell As Range
    Dim rCurrentCell As Range

    Set rLastCell = LastCell(ThisWorkbook.Worksheets("Sheet1"))

    With ThisWorkbook.Worksheets("Sheet1")
        'A For Each will step through each cell going across the columns and then down the rows.
        'Just need to reset if the it's the first column and check if the next cell is equal to the previous
        'and reset when it changes.
        For Each rCell In .Range(.Cells(1, 1), rLastCell)
            If rCell.Column = 1 Then
                Set rFirstCell = rCell
            ElseIf rCell.Value <> rFirstCell.Value Then
                If rCell.Column - rFirstCell.Column >= 10 Then
                    rFirstCell.Resize(, rCell.Column - rFirstCell.Column).Interior.Color = RGB(255, 0, 0)
                End If
                Set rFirstCell = rCell
            End If
        Next rCell
    End With

End Sub

Public Function LastCell(wrkSht As Worksheet, Optional Col As Long = 0) As Range

    Dim lLastCol As Long, lLastRow As Long

    On Error Resume Next

    With wrkSht
        If Col = 0 Then
            lLastCol = .Cells.Find("*", , , , xlByColumns, xlPrevious).Column
            lLastRow = .Cells.Find("*", , , , xlByRows, xlPrevious).Row
        Else
            lLastCol = .Cells.Find("*", , , , xlByColumns, xlPrevious).Column
            lLastRow = .Columns(Col).Find("*", , , , xlByColumns, xlPrevious).Row
        End If

        If lLastCol = 0 Then lLastCol = 1
        If lLastRow = 0 Then lLastRow = 1

        Set LastCell = wrkSht.Cells(lLastRow, lLastCol)
    End With
    On Error GoTo 0

End Function

【讨论】：