Combining data leaving out blanks

[Tino XXL]

Hi

Can you pls help me out with the following issue. You'll find a file in attachment.
The red field shows you the data I have. The green field shows you what I should get too.

I'm really stuck on this one and my boss expects a solution asap.

Kind regards
Tino XXL

[stnkynts]

Hello friend,

I started working out an answer for you but encountered a problem myself. Here is two different macros that should do around the same thing and should work. Only problem is that when i run it on your workbook it will not delete and shift up all the rows, just some of them. Maybe someone else here can weigh in.

Option Explicit

Sub masroiu()
Dim iCell As Range

For Each iCell In Range("A1:B46")
    If IsEmpty(iCell) = True Then
        iCell.Delete Shift:=xlUp
    End If
Next iCell

End Sub

Option Explicit

Sub Deleteblanks()
Dim alastrow As Long
Dim blastrow As Long
Dim iCell As Long

alastrow = Range("A" & Rows.Count).End(xlUp).Row
blastrow = Range("B" & Rows.Count).End(xlUp).Row

For iCell = 1 To alastrow
    If IsEmpty(Range("A" & iCell)) = True Then
        Range("A" & iCell).Delete Shift:=xlUp
    End If
Next iCell

For iCell = 1 To blastrow
    If IsEmpty(Range("B" & iCell)) = True Then
        Range("B" & iCell).Delete Shift:=xlUp
    End If
Next iCell

End Sub

[watersev]

one of the options to make it

Press Start

[snb]

1. empty all 'empty looking' cells in column B
2. Use

Sub tst()
  For Each ar In ThisWorkbook.Sheets(1).Columns(2).SpecialCells(4).Areas
    ar.Value = ar.Offset(1).Cells(ar.Cells.Count).Value
  Next
  ThisWorkbook.Sheets(1).Columns(1).SpecialCells(4).EntireRow.Delete
End Sub

PS. Trek je niet teveel van die bazen aan....