VBA method excel move cells to other row based on value

Question

I'm struggling with a VBA method in excel. I have a CSV that needs to be edited based on the category of the product.

The csv looks like this:

The result I want to achieve is this:

Here is the Method I wrote; I think I'm close, but its not working as desired yet.

Sub test()
    'c is a CELL or a range
    Dim c As Range

    'for each CELL in this range
    For Each c In Range("A2", Cells(Cells.SpecialCells(xlCellTypeLastCell).Row, 1))

        'Als de cel leeg is en de volgende niet dan
        If c = "" And c.Offset(1, 0) <> "" Then
            'verplaats inhoud lege cel naar 1 boven
            c.Offset(-1, 6) = c.Offset(0, 5)
            'Verwijder rij
            c.EntireRow.Delete       

        'Als de cel leeg is en de volgende ook dan
        ElseIf c = "" And c.Offset(1, 0) = "" Then
            'verplaats inhoud lege cel naar 1 boven
            If c.Offset(0, 5) <> "" Then
                c.Offset(-1, 6) = c.Offset(0, 5)

            'Als inhoud
            ElseIf c.Offset(1, 5) <> "" Then
                c.Offset(-1, 7) = c.Offset(1, 5)

            Else
                c.EntireRow.Delete
                c.Offset(1,0).EntireRow.Delete    
            End If

        End If
    Next
End Sub

There are some rows in the CSV that are totally empty, so this needs to be considered as well..

Answer 1

I'd loop through the rows and check whether the two rows below each entry are populated then set the value of the entry to the last populated value. You can then split this value to put the values into multiple columns.

Tip: When looping through cells and deleting rows you always want to start from the bottom and work your way to the top.

Try this:

Sub test()

Dim arr() as String
Dim x As Long, i as long, lRow as long

With ThisWorkbook.Sheets("SheetName")
    lRow = .Cells(.Rows.Count, 1).End(xlUp).Row

    'Insert 2 columns to hold the extra information
    .Columns("E:F").Insert

    For x = lRow to 2 Step -1

        'Delete rows that are completely blank
        If .Cells(x, "A").Value = "" And .Cells(x, "D").Value = "" Then
            .Cells(x, "A").EntireRow.Delete

        'Find the next entry
        ElseIf .Cells(x, "A").Value <> "" Then

            'Check if the 2nd row below the entry is populated
            If .Cells(x + 2, "A").Value = "" And .Cells(x + 2, "D").Value <> "" Then
                .Cells(x, "D").Value = .Cells(x + 2, "D").Value
                .Range(.Cells(x + 2, "D"), .Cells(x + 1, "D")).EntireRow.Delete

                'Split the strings using the "/" character, if there is also a space you will need to use "/ " instead, then populate the inserted columns
                arr = Split(.Cells(x, "D").Value, "/")
                For i = 0 to UBound(arr)
                    .Cells(x, 4 + i).Value = arr(i)
                Next i

            'If the 2nd row isn't populated only take the row below
            ElseIf .Cells(x + 1, "A").Value = "" And .Cells(x + 1, "D").Value <> "" Then
                .Cells(x, "D").Value = .Cells(x + 1, "D").Value
                .Cells(x + 1, "D").EntireRow.Delete

                'Split the strings using the "/" character, if there is also a space you will need to use "/ " instead, then populate the inserted columns
                arr = Split(.Cells(x, "D").Value, "/")
                For i = 0 to UBound(arr)
                    .Cells(x, 4 + i).Value = arr(i)
                Next i

            End If

        End If

    Next x

End With

End Sub