объединить ячейки в несколько столбцов на основе значения ячейки

Question

Я хотел бы автоматизировать объединение ячеек на основе столбца для нескольких столбцов на основе информации в конкретном столбце.

На основе исходного изображения значение стека будет определять значение no.строк для слияния для столбца Color, Stack и Size, как показано на скриншоте Outcome.

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

Dim srw As Long, frw As Variant
With Worksheets("Sheet1")
    With Intersect(.Columns(3), .UsedRange)
        srw = 0
        Do While srw < .Rows.Count
            frw = .Cells(srw + 1, 1).Value
            If Not IsError(frw) Then
                .Cells(srw + 1, 1).Resize(frw, 1).Offset(0, -1).Merge
                srw = srw + frw
            Else
                srw = .Cells(Rows.Count, 1).End(xlUp).Row
            End If
        Loop
    End With
End With

Начальный:

Результат:

Answer 1

Измените имя листа и диапазон при необходимости и попробуйте:

Option Explicit

Sub Test()

    Dim LastRow As Long
    Dim i As Long
    Dim Number_Of_Rows As Long
    Dim wsTest As Worksheet

    With wsTest
        LastRow = .Range("A" & Rows.Count).End(xlUp).Row
        For i = 2 To LastRow
            If .Range("C" & i).Value > 1 Then
                Number_Of_Rows = .Range("C" & i).Value
                With .Range("B" & .Range("C" & i).Row & ":B" & .Range("C" & i).Row + (Number_Of_Rows - 1))
                    .HorizontalAlignment = xlCenter
                    .VerticalAlignment = xlCenter
                    .MergeCells = True
                End With
                With .Range("C" & .Range("C" & i).Row & ":C" & .Range("C" & i).Row + (Number_Of_Rows - 1))
                    .HorizontalAlignment = xlCenter
                    .VerticalAlignment = xlCenter
                    .MergeCells = True
                End With
                With .Range("D" & .Range("C" & i).Row & ":D" & .Range("C" & i).Row + (Number_Of_Rows - 1))
                    .HorizontalAlignment = xlCenter
                    .VerticalAlignment = xlCenter
                    .MergeCells = True
                End With
            ElseIf .Range("C" & i).Value <> "" Then
                With .Range("B" & i & ":D" & i)
                    .HorizontalAlignment = xlCenter
                    .VerticalAlignment = xlCenter
                End With
            End If
        Next i
    End With

End Sub

Answer 2

Попробуйте этот код

Sub Test()
Dim x, r As Long, c As Long

Application.ScreenUpdating = False
    With Worksheets("Sheet1")
        For r = 2 To .Cells(Rows.Count, 1).End(xlUp).Row
            x = .Cells(r, 3).Value
            If IsNumeric(x) And x > 1 Then
                For c = 2 To 4
                    .Cells(r, c).Resize(x).Merge
                Next c
            End If
        Next r
    End With
Application.ScreenUpdating = True
End Sub