Excel meerdere regels splitsen naar kolommen

Vraag

dinsdag 18 mei 2021 21:06

Acties:

Topicstarter

Mijn vraag
In Excel heb ik verschillende producten in een cel staan. De producten zijn gescheiden door middel van een scheidingsteken /. Het aantal regels kan verschillen.
Hoe kan ik de producten scheiden zodat een deel in een kolom komt en het deel achter de / in een andere kolom?
Zie voorbeeld:
Afbeeldingslocatie: https://tweakers.net/i/olea_5JHau1X9o5KbX1U25KnqQQ=/full-fit-in/4000x4000/filters:no_upscale():fill(white):strip_exif()/f/image/p9HUsrQScEPxKjPk6cw82qcX.png?f=user_large

Afbeeldingslocatie: https://tweakers.net/i/olea_5JHau1X9o5KbX1U25KnqQQ=/full-fit-in/4000x4000/filters:no_upscale():fill(white):strip_exif()/f/image/p9HUsrQScEPxKjPk6cw82qcX.png?f=user_large

Relevante software en hardware die ik gebruik
Excel 2016 / 2019

Wat ik al gevonden of geprobeerd heb
Tekst naar kolommen werkt niet, omdat deze alleen de eerste regel pakt.
Verschillende zoekwoorden gebruikt in Google, maar die geven niet het gewenste resultaat.
Bijv: "meerdere regels splitsen naar 2 kolommen", "meerdere regels in 1 cel splitsen"

Enig idee of dit mogelijk is?

Beste antwoord (via Jimster op 26-05-2021 16:56)

dinsdag 25 mei 2021 17:22

dix-neuf

Excel

Als:
- Het blad waarin de gegevens staan "Blad1" heet;
- De gegevens in dat blad staan in kolom A, beginnend in A2;
- De gegevens er uitzien zoals in het eerste bericht van dit topic;
kun je onderstaande macro gebruiken.

code:

Sub macro1()
Dim a As Integer, k As Integer, x As Integer, y As Integer, L As Integer
With Sheets("Blad1")
.Columns("B:C").ClearContents
For y = 2 To .Cells(.Rows.Count, 1).End(xlUp).Row
a = 1: k = 1: L = Len(.Cells(y, 1))
If L > 0 Then
For x = 1 To L
If Mid(.Cells(y, 1), x, 3) = " / " Then
k = k + 1
.Cells(y, k) = .Cells(y, k) & Mid(.Cells(y, 1), a, x - a) & Chr(10)
x = x + 3: a = x
Do Until Mid(.Cells(y, 1), x, 1) = Chr(10) Or x = L + 1
x = x + 1
Loop
k = k + 1
.Cells(y, k) = .Cells(y, k) & Mid(.Cells(y, 1), a, x - a) & Chr(10)
If k = 3 Then k = 1
x = x + 1: a = x
End If
Next x
End If
If x - a > 1 Then
.Cells(y, 2) = .Cells(y, 2) & Mid(.Cells(y, 1), a, L + 1)
End If
Next y
End With
End Sub

[ Voor 6% gewijzigd door dix-neuf op 25-05-2021 17:27 ]

Alle reacties

Pagina: 1

Reageer

Onderwerpen

Vraag

Beste antwoord (via Jimster op 26-05-2021 16:56)

Alle reacties