Скопируйте значения ячейки в строки выше на основе значения ячейки

Question

Я пытаюсь разработать простую визуализацию компоновки стойки. Я могу сделать так, чтобы каждый элемент отображался в стойке в самом нижнем положении стойки (т. Е. Элемент высотой 5 РУ, занимающий слоты 1-5, появится в слоте 1) (например, если в моей стойке 20 рупий, слот 1 (снизу стойка) будет в ряду 20, а слот 20 (верх стойки) будет в ряду 1). Однако я хочу иметь возможность объединить данные в заполненных строках с пустыми ячейками выше. Таким образом, элемент в слоте 1 будет иметь данные в строке 20, следующие 4 строки будут пустыми, пока следующий элемент не появится в слоте 6 (строка 15).

Каждая строка имеет 4 ячейки для информации, которую необходимо объединить (то есть диапазон B: E или эта строка) Наименование, высота RU, ID1, ID2

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

Мне не удалось найти какой-либо существующий код, который делает что-то подобное, однако я смог адаптировать некоторый код для обработки половины проблемы слияния, поэтому, если данные были скопированы в пустые ячейки выше оно будет успешно объединено.

Sub MergeCells()
'set your data rows here
Dim Rows As Integer: Rows = 38

Dim First As Integer: First = 19
Dim Last As Integer: Last = 0
Dim Rng As Range

Application.DisplayAlerts = False
With ActiveSheet
    For i = 1 To Rows + 1
        If .Range("B" & i).Value <> .Range("B" & First).Value Then
            If i - 1 > First Then
                Last = i - 1

                Set Rng = .Range("B" & First, "B" & Last)
                Rng.MergeCells = True
                Set Rng = .Range("C" & First, "C" & Last)
                Rng.MergeCells = True
                Set Rng = .Range("D" & First, "D" & Last)
                Rng.MergeCells = True
                Set Rng = .Range("E" & First, "E" & Last)
                Rng.MergeCells = True

            End If

            First = i
            Last = 0
        End If
    Next i
End With
Application.DisplayAlerts = True

End Sub

Если кто-то может посоветовать, как скопировать данные, я смогу найти решение.

ОБНОВЛЕНИЕ ... на основе ответов @TimWilliam я собрал следующий код:

Sub MergeCellsX()
    'set your data rows here
    Dim Rows As Integer: Rows = 38
    Dim col As Range
    Dim First As Integer: First = 19
    Dim Last As Integer: Last = 51
    Dim rng As Range

   With ActiveSheet

    Set rng = .Range("B" & First, "B" & Last)
    rng.Cells(1).Value = rng.Cells(rng.Cells.Count).Value 'copy last value to first cell
    rng.MergeCells = True

    Application.DisplayAlerts = False

    For Each col In .Range("B" & First & ":E" & Last).Columns
    MergeWithLastValue col
    Next col

    End With

    Application.DisplayAlerts = True
End Sub

Однако данные помещаются в самый верхний диапазон. Не учитывается значение высоты RU в столбце C.

Я не уверен, где

Sub MergeWithLastValue(rng As Range)
    With rng
        .Cells(1).Value = .Cells(.Cells.Count).Value
        .MergeCells = True
    End With
End Sub

строка кода должна сидеть, чтобы ссылаться на это значение?

До и после:

Answer 1

РЕДАКТИРОВАТЬ - заменить все подходом, основанным на значении в ячейке "RU"

Sub MergeAreas()

    Dim rw As Long, x As Long, rng As Range
    Dim RU As Long, rngMerge As Range, col As Range
    Dim rwEnd As Long

    rw = 23

    rwEnd = rw - 20
    Do While rw >= rwEnd
        ' "Item#" column is 2/B
        Set rng = ActiveSheet.Cells(rw, 3).Resize(1, 4)

        If rng.Cells(1) <> "" Then

            RU = rng.Cells(2).Value

            'Here you need to check that the "RU space" doesn't extend
            '  past the top of the block

            Set rngMerge = rng.Offset(-(RU - 1), 0).Resize(RU)

            'here you should check for "collisions" between this
            '  item and anything above it in its RU space, otherwise
            '  the item above will get wiped out

            For Each col In rngMerge.Columns
                col.Cells(1).Value = col.Cells(col.Cells.Count).Value
                Application.DisplayAlerts = False
                col.MergeCells = True
                Application.DisplayAlerts = True
            Next col
            rw = rw - RU
        Else
            rw = rw - 1
        End If

    Loop

End Sub