Inhoud cellen verplaatsen/efficienter opslaan op basis van criteria

[JMu]

Goedemiddag,

Graag zou ik middels een formule of eventueel in VBA de data in bereik A5:H13 in elkaar "schuiven". Dit lijkt mij het handigst via de knop "gegevens samenvoegen".

Voorwaarde is dat elke cel vanaf A5 8 karakters bevat. Zodra er cellen in de volgorde B5, C5, D5, E5, F5, G5, H5, A6, B6 enz. bestaan waar minder dan 8 karakters aanwezig zijn moeten deze opgevuld worden met de inhoud van de volgende cel(len), te beginnen met de karakters vanaf de linkerkant. Zodra er 8 karakters zijn moet er in de volgende cel verder worden gegaan. Zie voorbeeldbestand, in het geel een impressie zoals het moet worden.

Helaas kom ik er met mijn beperkte kennis niet uit...

Alvast bedankt voor de hulp!

 

[wampier]

Let op, deze code plaatst de juiste tekst in je gegeven voorbeeld. De output moet dus aangepast worden aan waar het in je uiteindelijke file moet komen!

Sub test()
Dim opslag As String
Dim schraap As String

For Each cell In [a5:h13]
    opslag = opslag + cell.Value
Next cell

Dim teller As Long
Dim xc As Long
Dim yc As Long
teller = 0

While Len(opslag) > 8
    schraap = Left(opslag, 8)
    opslag = Right(opslag, Len(opslag) - 8)
    xc = (teller Mod 8) + 1
    yc = WorksheetFunction.RoundDown(teller / 8, 0) + 1
    teller = teller + 1
    Cells(22 + yc, xc).NumberFormat = "@"
    Cells(22 + yc, xc).Value2 = schraap
Wend

xc = (teller Mod 8) + 1
yc = WorksheetFunction.RoundDown(teller / 8, 0) + 1
Cells(22 + yc, xc).NumberFormat = "@"
Cells(22 + yc, xc).Value2 = opslag

End Sub

 

[JMu]

Let op, deze code plaatst de juiste tekst in je gegeven voorbeeld. De output moet dus aangepast worden aan waar het in je uiteindelijke file moet komen!

Sub test()
Dim opslag As String
Dim schraap As String

For Each cell In [a5:h13]
    opslag = opslag + cell.Value
Next cell

Dim teller As Long
Dim xc As Long
Dim yc As Long
teller = 0

While Len(opslag) > 8
    schraap = Left(opslag, 8)
    opslag = Right(opslag, Len(opslag) - 8)
    xc = (teller Mod 8) + 1
    yc = WorksheetFunction.RoundDown(teller / 8, 0) + 1
    teller = teller + 1
    Cells(22 + yc, xc).NumberFormat = "@"
    Cells(22 + yc, xc).Value2 = schraap
Wend

xc = (teller Mod 8) + 1
yc = WorksheetFunction.RoundDown(teller / 8, 0) + 1
Cells(22 + yc, xc).NumberFormat = "@"
Cells(22 + yc, xc).Value2 = opslag

End Sub

Dankjewel wampier! De code doet precies wat ik bedoel Je geeft aan dat ik zelf de plaats van de output moet definieren, dit heb ik geprobeerd. Nu heb ik wat parameters veranderd in de code, in de hoop daarmee de output rechtstreeks in mijn bereik te plaatsen... maar dit heeft tot gevolg dat de code wel wordt verplaatst maar er ook dingen misgaan. Ik vrees dat ik niet de juiste zaken aanpas. Of moet er code worden toegevoegd om het bereik te definieren?

Zou je een aanzet willen geven hoe ik de output plaats in/vanaf cel J2?

Wederom dank!

 

[wampier]

zoiets dan:

Sub test()
Dim opslag As String
Dim schraap As String

For Each cell In [a5:h13]
    opslag = opslag + cell.Value
Next cell

Dim teller As Long
Dim xc As Long
Dim yc As Long
teller = 0

While Len(opslag) > 8
    schraap = Left(opslag, 8)
    opslag = Right(opslag, Len(opslag) - 8)
    xc = (teller Mod 8) + 1
    yc = WorksheetFunction.RoundDown(teller / 8, 0) + 1
    teller = teller + 1
    Cells(1 + yc, 9 + xc).NumberFormat = "@"
    Cells(1 + yc, 9 + xc).Value2 = schraap
Wend

xc = (teller Mod 8) + 1
yc = WorksheetFunction.RoundDown(teller / 8, 0) + 1
Cells(1 + yc, 9 + xc).NumberFormat = "@"
Cells(1 + yc, 9 + xc).Value2 = opslag

End Sub

 

[JMu]

Bedankt wampier! Helemaal naar wens! Kan ik weer verder knutselen