Excel VBA Замораживание двойной петли для окрашивания определенного диапазона при соблюдении критериев - PullRequest
Новая
       18

Excel VBA Замораживание двойной петли для окрашивания определенного диапазона при соблюдении критериев

0 голосов
/ 24 апреля 2018

Hello!

Я все еще новичок в 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, то для всех строк в этой «группе» должен быть окрашен их столбец F.

Основная идея моего кода состоит в том, чтобы найти «группу» и использовать groupfrom и groupto, чтобы установить диапазон groupfinal, равный ячейкам группы в столбце F.
Затем используйте метод range.find, чтобы проверить наличие «Хранилища».

Я пытался найти и устранить неисправность, но безуспешно.
Есть идеи, почему код не работает?

Я ценю любую помощь, и я открыт для идей с подходом, отличным от моего кода.
Заранее спасибо!

1 Ответ

0 голосов
/ 25 апреля 2018

Поскольку все ваши группы будут сгруппированы, а не смешаны, тогда для проверки значения группы можно использовать скрипт 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
...