vba - 如果满足条件，Excel VBA冻结双循环为特定范围着色

Question

你好！

我还是 VBA 的新手，但是使用几乎我所有的脑细胞，我设法构建了下面的代码。
但是，当我执行宏时，Excel 似乎工作了很长时间，但什么也没做。我没有收到任何错误消息，但似乎 Excel 陷入了无限循环。
我怀疑我的代码某处存在重大缺陷，但我似乎无法弄清楚在哪里。

Sub Makro_color_cells()
Application.ScreenUpdating = False

Dim groupfrom As Range
Dim groupto As Range
Dim groupfinal As Range

lastrow = Cells(Rows.Count, "B").End(xlUp).Row
x = 4
t = 0

Do While x < lastrow

    Set groupfrom = Cells(x - 1, "F")

    Cells(x - 1, "B").Activate
    Do While ActiveCell = ActiveCell.Offset(1, 0)
       t = t + 1
       ActiveCell.Offset(1, 0).Activate
    Loop

    x = x + t
    Set groupto = Cells(x - 1, "F")
    Set groupfinal = Range(groupfrom, groupto)

    If Not (groupfinal.Find("Storage") Is Nothing) Then
    Range("groupfinal").Interior.ColorIndex = 3
    End If

    t = 0
    Set groupfrom = Nothing
    Set groupto = Nothing
    Set groupfinal = Nothing

Loop

Application.ScreenUpdating = True
End Sub

代码的目的是根据某些标准为 F 列中的某些单元格着色：
B 列包含数字，其中重复项彼此相邻。将 B 列中具有相同值的所有行视为一个“组”。
现在，如果“组”中的一行或多行在 F 列中包含文本“Storage”，则该“组”中的所有行都应将其 F 列着色。

我的代码背后的基本思想是定位“组”并使用groupfrom并groupto设置一个groupfinal等于F列中组单元格的范围。
然后使用该range.find方法测试是否出现“存储”。

我尝试了故障排除，但没有运气。
任何想法为什么代码不起作用？

我感谢任何帮助，并且我对采用与我的代码不同的方法的想法持开放态度。
先感谢您！

标签： vbaexcelwhile-loopfreeze

Answer 1

由于您的所有组将组合在一起而不是混合在一起，因此可以使用 vba 脚本来检查组值，使用该值的总数来定义范围并更改 F 列中的单元格颜色：

Sub Makro_color_cells()

Dim LastRow
Dim CurrentRow
Dim GroupValue
Dim GroupTotal
Dim GroupCheck

GroupValue = Range("B1").Value ' get the first value to search
CurrentRow = 1 ' Define the starting row

    With ActiveSheet ' find the last used cell in the column
        LastRow = .Cells(.Rows.Count, "B").End(xlUp).Row
    End With

    For x = 1 To LastRow ' start the reapat until last cell reached

        GroupTotal = Application.WorksheetFunction.CountIf(Range("B1:B" & LastRow), GroupValue) ' search for total of the group values
        GroupCheck = Application.WorksheetFunction.CountIf(Range("F" & CurrentRow & ":F" & CurrentRow + GroupTotal - 1), "Storage") ' search for "Storage" in the range from current row to total rows of the same group values

        If GroupCheck >= 1 Then ' if the "Storage" search is equal to one or more then colour the range of cells
            Range("F" & CurrentRow & ":F" & CurrentRow & ":F" & CurrentRow + GroupTotal - 1).Interior.ColorIndex = 3
        End If

        CurrentRow = CurrentRow + GroupTotal ' We know how many cells are in the same group so we can bypass them and move the current row to the next group of values
        GroupValue = Range("B" & CurrentRow).Value ' Get the value for the new group

        If GroupValue = "" Then ' Check the new group value and if it is nothing then we can exit the 'For Next x'
            Exit For
        End If

    Next x

End Sub