CODEWITHSUNDEEP
excelvba
Icaruim14
Icaruim14

Reputation: 51

Copy cell values to rows above based on a cell value

I am trying to develop a simple visualisation of a rack layout. I am able to get each item to appear in the rack at its lowest rack position (i.e. A 5 RU tall item that occupies slots 1-5 will appear in slot 1) (e.g. if my rack has 20 RUs, slot 1 (bottom of the rack) will be in row 20 and slot 20 (top of the rack) will be in row 1). However i want to be able to merge the data in filled rows with the blank cells above. So the item in slot 1 will have data in row 20, the next 4 rows will be blank until the next item appears in slot 6 (Row 15).

Each row has 4 cells on information to merge (i.e. range B:E or that row) Item Name, RU height, ID1, ID2

I have realised I cannot use merge functions directly as it will overwrite the cells with the blanks in the top row. I believe i would need a function to copy the data row multiple times into the blank cells, based on the value in the RU height cell, before merging each column individually based on merging cells containing identical values.

I haven't been able to find any existing code that does something like this, I have however been able to adapt some code to handle the merge half of the problem, so if the data has been copied into the blank cells above it will merge successfully.

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

If someone can advise on how to get the data copied I should be able to cobble together a solution.

UPDATE..based on @TimWilliam answers i have put together the following code:

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

However it is putting the data in the very top on the range. It isnt taking into account the RU height value in column C.

I am not sure where the 

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

line of code should sit to reference this value?

Before and After:
Before and After

Upvotes: 0

Views: 112

Answers (1)

Tim Williams
Tim Williams

Reputation: 166126

EDIT - replaced everything with an approach based off the value in the "RU" cell

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

Upvotes: 0

Related Questions