Excel VBA - Need to get data into next row, and remove from existing place -

on same worksheet, i'm trying compact cell data, i.e. move cells value next each other instead of spread apart. original sheet looks this:

the desired output this:

i have tried below code solve problem, , sorry i'm new here don't know how ask question

sub selectrangea()     sheets("sheet1").select    range("a1:cf1").select    application.cutcopymode = false    selection.copy   sheets("sheet1")    lst = .range("a" & rows.count).end(xlup).row + 1    .range("a" & lst).pastespecial xlpastecolumnwidths    .range("a" & lst).pastespecial xlpastevalues  end  end sub 

this code solves problem per sample data.

dim c long  c = 1 worksheets("sheet6")     c = .cells(1, c).end(xltoright).end(xltoright).column     while c < .columns.count         .range(.cells(1, c), .cells(1, c).end(xltoright))             .parent.cells(rows.count, 1).end(xlup).offset(1, 0).resize(1, .columns.count) = .cells.value             .clear         end         c = .cells(1, c).end(xltoright).column     loop end 

if 1 of 'islands' of data in first row single cell have accommodate special condition.