Перебирайте ячейки и отображайте значения в окне сообщений, используя бесконечный цикл

Question

Я пишу фрагмент кода, который перебирает все значения в столбце (пока он не достигнет пустой строки) и добавляет значения, содержащие «Wooden», к диапазону, который будет отображаться в конце в окне сообщения.

На изображении, связанном Здесь , оно начнется с A2 и пойдет вниз по каждой строке, проверьте значение в столбце C для этих американских горок и, если C деревянное, добавьте значение в Aв диапазон, который будет отображаться в конце.

Код:

 Sub checktype()
 Dim wooden As Range
 Range("A2").Select
 Do While ActiveCell.Value <> ""
     If ActiveCell.Offset(0, 2).Value = "Wood" Then
         If wooden Is Nothing Then
             Set wooden = ActiveCell
         Else
             Set wooden = Union(wooden, ActiveCell)
         End If
     End If
     ActiveCell.Offset(1, 0).Select
 Loop
 MsgBox wooden
 End Sub

Тем не менее, код возвращает только «Великий национальный» - первая запись, которая имеет деревянный столбец в столбце C.

Answer 1

Я бы использовал массив для более быстрой обработки, и, поскольку я думаю, что вам нужны строковые значения, вам не нужно объединять диапазоны, а вместо этого объединять значения соответствующих ячеек. Использование массива и избегание .Select намного быстрее. Сбор квалификационных диапазонов с помощью Union, а затем объединение значений немного сложнее, поскольку диапазон объединения может не содержать непрерывных диапазонов, которые можно легко проиндексировать, транспонировать и объединить в строку.

Option Explicit
Public Sub checktype()
    Dim wooden As String, loopRange As Range, arr(), i As Long
    With ThisWorkbook.Worksheets("Sheet1") '<== change to your sheet
        Set loopRange = .Range(.Range("A2"), .Range("A2").End(xlDown))
        Set loopRange = loopRange.Resize(loopRange.Rows.Count, 3)

        If loopRange.Count = 1 Then
            ReDim arr(1, 1): arr(1, 1) = .Range("A2").Value
        Else
            arr = loopRange.Value
        End If

        For i = LBound(arr, 1) To UBound(arr, 1)
            If arr(i, 3) = "Wood" Then
                wooden = wooden & Chr$(32) & arr(i, 1)
            End If
        Next
    End With
    Msgbox wooden
End Sub