Question

我正在尝试开发机架布局的简单可视化。我能够使每个项目以最低的机架位置出现在机架中（即，占用1-5号插槽的5 RU高的项目将出现在插槽1中）（例如，如果我的机架有20 RU，则插槽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

结束子

如果有人可以建议如何复制数据，我应该可以提出解决方案。

基于@TimWilliam的UPDATE ..我回答了以下代码：

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

但是，它将数据放在范围的顶部。它没有考虑C列中的RU高度值。

我不确定

在哪里

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

根据单元格值将单元格值复制到上面的行

1 个答案: