Цикл и объединить значение 2 ячеек между определенным диапазоном

Question

Я пытаюсь определить конкретный диапазон в столбце A, объединить две ячейки в указанном диапазоне и удалить пустую ячейку. Мне удалось собрать код, и он отлично справляется со своей задачей. Но я не знаю, как зациклить , чтобы определить следующий диапазон. Любая помощь будет оценена.

Как показано на рисунке ниже и в коде, во-первых, я нахожу и выбираю диапазон между двумя (MCS) в столбце A с условием, что если между двумя MCS строк больше 8. Затем я объединяю первые 2 ячейки сразу после MCS и удаляю пустую строку.

Приведенный ниже код хорошо работает для первого диапазона, но я не могу выполнить цикл для определения следующего диапазона от 22 до 32 строк и выполнения конкатенации. Я хочу включить цикл в столбце A, так как MCS будет больше.

Sub MergeStem()
    Dim findMCS1 As Long
    Dim findMCS2 As Long
    Dim myCount As Integer
    Dim myStems As Long
    Dim mySelect As Range
    Dim c As Range

    findMCS1 = Range("A:A").Find("MCS", Range("A1")).Row
    findMCS2 = Range("A:A").Find("MCS", Range("A" & findMCS1)).Row

    myCount = Range("A" & findMCS1 + 1 & ":A" & findMCS2 - 1).Cells.Count
    Range("B1").Value = myCount
    MsgBox "Number of rows =" & myCount

    Set mySelect = Selection

    If myCount > 8 Then
        myStems = Range("A" & findMCS1 + 2 & ":A" & findMCS2 - 9).Select

        Set mySelect = Selection

        For Each c In mySelect.Cells
            If firstcell = "" Then firstcell = c.Address(bRow, bCol)
            sArgs = sArgs + c.Text + " "

            c.Value = ""
        Next
        Range(firstcell).Value = sArgs
    End If

    Columns("A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete

    Application.ScreenUpdating = True

End Sub

Answer 1

Вы можете попробовать:

Option Explicit

Sub test()

    Dim i As Long, Lastrow As Long, Startpoint As Long, Endpoint As Long, Diff As Long
    Dim str As String

    With ThisWorkbook.Worksheets("Sheet1")

        Lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row

        Startpoint = 0
        Endpoint = 0

        For i = Lastrow To 2 Step -1

            str = .Range("A" & i).Value

            If str = "MCS" And Startpoint = 0 Then
                Startpoint = i
            ElseIf str = "MCS" And Startpoint <> 0 Then
                Endpoint = i
            End If

            If Startpoint > 0 And Endpoint > 0 Then

                Diff = Startpoint - Endpoint

                If Diff > 8 Then

                    .Range("A" & Endpoint + 1).Value = .Range("A" & Endpoint + 1).Value & " " & .Range("A" & Endpoint + 2).Value
                    .Rows(Endpoint + 2).EntireRow.Delete

                    Startpoint = 0
                    Endpoint = 0

                End If

            End If

        Next i

    End With

End Sub