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

Answer 2

You can move the last 2 columns and use Text To Columns to split the column:

Sub test() ': Cells.Delete: [A1:F1,A3:F3] = [{1,2,3,"a/b/c",7,8}] ' used for testing
    Dim rng As Range
    Set rng = Sheet1.UsedRange                 ' set the range here

    rng.Columns("E:F").Cut
    rng.Resize(, 2).Insert xlToRight  ' move the last 2 columns

    rng.Columns("D").TextToColumns OtherChar:="/" ' split the last column

    rng.SpecialCells(xlCellTypeConstants).EntireRow.Hidden = True ' hide non-empty rows
    rng.SpecialCells(xlCellTypeVisible).EntireRow.Delete ' delete visible rows
    rng.EntireRow.Hidden = False ' un-hide the rows

    Set rng = rng.CurrentRegion
    rng.Resize(, 2).Cut    ' move the 2 columns back to the end
    rng.Resize(, 2).Offset(, rng.Columns.Count).Insert xlToRight
End Sub

The images are blocked where I am now, so the columns might need some adjustment