I have a worksheet which has data in multiple rows and need to collapse and move this information upwards and remove and null spaces using a single column as a key reference point.

For example, I have a table where column A contains the values a, and CB. Columns B, C and D also have data, but my rows only contain data for 2 columns leaving the other columns empty. I need to move all the values in the rows upwards filling in the blanks if the first column matches. After they columns are moved up, the last rows can have null data, I just need to move data upwards.

Here is what I am trying to do. I do not have columns and row headers listed

a  1      null      null
a  2      null      null
a null     1        null
a null     2        null    
a null    null        1
a null    null        2     
a null    null        3
B  1      null      null
B  2      null      null
B null     1        null
B null     2        null    
B null    null        1
B null    null        2     
B null    null        3
C  1      null      null
C  2      null      null
C null     1        null
C null     2        null    
C null     3        null
C null    null        1     
C null    null        2

I need to consolidate and move data to make it

a  1        1      1
a  2        2      2
a null   null     3
B  1        1      1
B  2        2      2
B  null   null     3
C  1        1      1
C  2        2      2
C  null    3     null

Can anyone help?


Starting with:

enter image description here

Running the macro MAIN():

Dim DidSomething As Boolean

Sub MAIN()
    DidSomething = True
    While DidSomething
        Call KompactData
    Call RowKiller
End Sub

Sub KompactData()
    Dim N As Long, i As Long
    Dim j As Long, v As Variant

    N = Cells(Rows.Count, "A").End(xlUp).Row
    DidSomething = False

    For j = 2 To 4
        For i = 2 To N
            v = Cells(i, j).Value
            If (v <> "") And (Cells(i - 1, j) = "") And (Cells(i, 1) = Cells(i - 1, 1)) Then
                Cells(i - 1, j) = v
                Cells(i, j).ClearContents
                DidSomething = True
            End If
        Next i
    Next j
End Sub

Sub RowKiller()
    Dim N As Long, i As Long, r As Range
    N = Cells(Rows.Count, "A").End(xlUp).Row
    With Application.WorksheetFunction
        For i = N To 1 Step -1
            Set r = Range(Cells(i, 1), Cells(i, 4))
            If .CountBlank(r) = 3 Then
                r.Delete Shift:=xlUp
            End If
        Next i
    End With
End Sub

will produce:

enter image description here

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.