Код для объединения соседних ячеек с использованием VBA больше не работает, и я не могу найти проблему

Question

Я пытаюсь выяснить, что не так с кодом, но, похоже, не могу выяснить. Он отлично работает с другими листами, но с этим всегда подразумевается ошибка, и структура точно такая же.

Ошибка "Ошибка приложения или объекта" отображается в строке кода Do Пока .

Он работает в 3-м ряду, но не в 4-м

Вот изображение листа:

Кто-нибудь знает, как исправить эту ошибку? Заранее спасибо

Sub BPS_MergeCells()
    Application.DisplayAlerts = False

    Dim rng As Range
    Dim LastColumn As Long
    Dim ColumnsInRange As Long
    Dim r As Long
    Dim c As Long

    'Last Column Used
    LastColumn = ThisWorkbook.Sheets("Blast Pro Series").Cells(3, Columns.Count).End(xlToLeft).Column

    'Rows
    For r = 3 To 4
        'Columns
        For c = 1 To LastColumn
            Do While ThisWorkbook.Sheets("Blast Pro Series").Cells(r, c) = ThisWorkbook.Sheets("Blast Pro Series").Cells(r, c + 1)
                ColumnsInRange = ColumnsInRange + 1
                c = c + 1
            Loop

            Set rng = Range(Cells(r, c - ColumnsInRange), Cells(r, c))
            rng.Select
            With Selection
                .HorizontalAlignment = xlCenter
                .VerticalAlignment = xlBottom
                .WrapText = False
                .Orientation = 0
                .AddIndent = False
                .IndentLevel = 0
                .ShrinkToFit = False
                .ReadingOrder = xlContext
                .MergeCells = False
            End With
            Selection.Merge
            ColumnsInRange = 0
        Next c
    Next r
    Application.DisplayAlerts = True
End Sub

Answer 1

Как указано в комментариях, вы меняете переменную, которая используется в цикле for в другом цикле, и эта переменная может превышать last_column.Для этого создайте вспомогательную переменную следующим образом:

Sub BPS_MergeCells()
    Application.DisplayAlerts = False

    Dim rng As Range
    Dim LastColumn As Long
    Dim ColumnsInRange As Long
    Dim r As Long
    Dim c As Long
    Dim c_aux As Long

    'Last Column Used
    LastColumn = ThisWorkbook.Sheets("Blast Pro Series").Cells(3, Columns.Count).End(xlToLeft).Column

    'Rows
    For r = 3 To 4
        'Columns
        For c = 1 To LastColumn
            c_aux = c
            Do While c_aux < LastColumn And ThisWorkbook.Sheets("Blast Pro Series").Cells(r, c_aux) = ThisWorkbook.Sheets("Blast Pro Series").Cells(r, c_aux + 1)
                ColumnsInRange = ColumnsInRange + 1
                c_aux = c_aux + 1
            Loop

            Set rng = Range(Cells(r, c), Cells(r, c_aux))
            rng.Select
            With Selection
                .HorizontalAlignment = xlCenter
                .VerticalAlignment = xlBottom
                .WrapText = False
                .Orientation = 0
                .AddIndent = False
                .IndentLevel = 0
                .ShrinkToFit = False
                .ReadingOrder = xlContext
                .MergeCells = False
            End With
            Selection.Merge
            ColumnsInRange = 0
        Next c
    Next r
    Application.DisplayAlerts = True
End Sub