inhoud cellen opschuiven zodat lege cellen onder komen

[abracadaver909]

Beste Helpmij-ers,

Voor het werk heb ik een excel-bestand gemaakt waarin met een macro de inhoud van enkele cellen worden gekopieerd naar andere cellen, waarna de eerste cellen worden geleegd.
De inhoud wordt gekopieerd onder de laatste gevulde cel. Dit geeft echter een probleem: de ruimte is beperkt en op deze wijze worden alle lege cellen boven de laatste gevulde cel niet benut.

Ik zoek nu een methode om de reeds gevulde cellen op te schuiven naar boven, zo dat de gevulde cellen aansluitend zijn, met daaronder de lege cellen. Zie voorbeeld (simpele weergave).Bekijk bijlage Map1.xls

Is er een methode om dit voor elkaar te krijgen?

Bij voorbaat dank,
Chris

 

[abracadaver909]

Na een aantal dagen de smerigste woorden eruit gegooid te hebben, heb ik dit voor elkaar gekregen en ben er best tevreden mee

Sub Knop1_Klikken()
Application.ScreenUpdating = False

Dim RowCount As Long
RowCount = Application.CountA(Range("B3:B18")) 'telt het aantal gevulde cellen in range en geeft weer als RowCount

'herhaalt actie knop 2 zoveel als getelde regels in rij B + het aantal regels boven de range
Do While Cells(18, "b").End(xlUp).Row > RowCount + 2
    Call Opschuiven
Loop

Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub

Deze macro ook opnemen in module, maar niet gekoppeld aan een knop oid:

Sub Opschuiven()

Dim r As Long
Dim c As Long
'bepaalt de onderste cel met inhoud. Rij B gekozen omdat die waardes altijd zijn ingevuld. gebruik van range en end(xlup) nodig voor onder- en bovengrens
With ActiveSheet
        r = .Cells(18, "A").End(xlUp).Row
        c = Range("B3:B18").End(xlUp).Offset(0, -1).Column
End With
'ter controle wordt waarde in cellen weergegeven
 'Range("d1").Value = r
 'Range("e1").Value = c
 
'resize de selectie en kopieert selectie
Cells(r, c).Resize(2, 3).Copy

'selecteert bovenste cel in range
Range("B3:B18").Cells(1).Offset(0, -1).Select

'van geselcteerde cel wordt bepaalt of deze inhoud heeft. Zoja, dan cel daaronder selecteren en deze actie herhalen. zonee, plakken wat gekopieert is.
Do While Len(ActiveCell.Value) > 0
    Selection.Offset(1).Select
Loop
    ActiveSheet.Paste

'Selection.Offset(1).Select
Cells(r, c).Resize(2, 3).Value = Empty

End Sub

Knop1 maken en macro Knop1_klikken eraan koppelen en werkt uitstekend, dus opgelost.

Mocht iemand nou ruimte voor verbetering zien, dan hoor ik dat graag.