Excel VBA 如果满足条件,则冻结双循环以对特定范围着色
Excel VBA Freezing double loop to color certain range if criteria is met
您好!
我对 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 列中具有相同值的所有行视为 "group".
现在,如果 "group" 中的一行或多行在 F 列中包含文本 "Storage",则该 "group" 中的所有行都应将其 F 列着色。
我的代码背后的基本思想是找到 "group" 并使用 groupfrom
和 groupto
设置范围 groupfinal
等于列 F 中组的单元格.
然后使用 range.find
方法测试是否出现 "Storage".
我尝试了故障排除,但没有成功。
知道为什么代码不起作用吗?
感谢任何帮助,并且我愿意接受与我的代码不同的想法。
提前致谢!
由于您所有的组都将组合在一起而不是混合在一起,因此可以使用 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
您好!
我对 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 列中具有相同值的所有行视为 "group".
现在,如果 "group" 中的一行或多行在 F 列中包含文本 "Storage",则该 "group" 中的所有行都应将其 F 列着色。
我的代码背后的基本思想是找到 "group" 并使用 groupfrom
和 groupto
设置范围 groupfinal
等于列 F 中组的单元格.
然后使用 range.find
方法测试是否出现 "Storage".
我尝试了故障排除,但没有成功。
知道为什么代码不起作用吗?
感谢任何帮助,并且我愿意接受与我的代码不同的想法。
提前致谢!
由于您所有的组都将组合在一起而不是混合在一起,因此可以使用 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