splitsen van data naar meerdere cellen

[shivalli]

Dag lezers,
Wie kan mij helpen met onderstaande probleem.
Ik heb de data van een toets geexporteerd uit een bepaalde programma. Het gaat in principe steeds om 5 subvragen; maar de antwoorden komen allemaal in 1 cel te staan in excel. Wat ik wil is bij elke dubbele punt (dan begint de respons op de volgende vraag) het antwoord in een nieuwe cel onder.
Onderstaande code doet het voor 1 vraag.
sub splitsen()
DataArray = Application.Transpose(Split(Range("B3"), ":")) Range("B3").Resize(UBound(DataArray), 1) = DataArray
end sub
Wie kan mij helpen om de code te bewerken dat het ook werkt voor alle vragen
Bijvoorbaat dank!
S

 

[wampier]

Wat is er mis met de ingebouwde text-naar-kolommen functie? In principe is het ombouwen van de functie niet moeilijk, maar splitsen op : werkt in principe prima

 

[shivalli]

De ingebouwde text naar kolommen functie zou prima werken, echter krijg ik niet de antwoorden per student onder elkaar maar naast elkaar. Dat wil ik juist niet ivm ivm de verdere verwerking. (zie aangepaste bijlage)
Ik hoop dat jullie mij verder kunnen helpen.

Groetjes

 

[wampier]

Ok duidelijk, mag de output op een ander blad / kolom? Converteren op de plaats zelf kan in principe wel, maar maakt het antwoord een stuk gecompliceerder

 

[shivalli]

Wampier,
Het liefst een ander kolom, maar een tabblad mag ook.
Hoeft niet op de zelfde plaats.
Dank alvast.
gr,
S

 

[wampier]

van kolom B naar E, startende in B3 met de originele data, E de output.

Sub splitsen()
Dim DataArray As Variant
For Each cell In Range([b3], [b65000].End(xlUp))
    If cell.Value <> "" Then
        DataArray = Application.Transpose(Split(cell.Value, ":"))
        [e65000].End(xlUp).Offset(1).Resize(UBound(DataArray), 1) = DataArray
    End If
Next cell
End Sub

 

[shivalli]

Wampier,
Dit is precies wat ik wil.
hartelijk dank!!!
Weer wat bij geleerd.
groetjes,
S

 

[Warme bakkertje]

In 1 schrijfbewerking (als het om snelheid en grotere bereiken gaat)

Sub splitsen()
    Dim a As Variant, buf(), i As Long, j As Long, x As Long
    With Sheets("Blad1")
        a = .Range(.[b3], .[B65536].End(xlUp)).Value
        For j = 1 To UBound(a)
            For i = 0 To UBound(Split(a(j, 1), ":"))
                ReDim Preserve buf(x)
                buf(x) = Split(a(j, 1), ":")(i)
                x = x + 1
            Next i
        Next j
    .Range("E2").Resize(UBound(buf)) = Application.Transpose(buf)
    End With
End Sub

 

[shivalli]

dankjewel!
Dit kan ik ook goed gebruiken voor een ander bestand!
gr,
S

 

[snb]

of

sub snb()
  for each cl in columns(2).specialcells(2)
    if cl.row>2 then c01=c01 & ":" & cl.value
  next
  sn=split(mid(c01,2),":")
  cells(2,5).resize(ubound(sn)+1)=application.transpose(sn)
end Sub

en met een beetje geluk (geen lege cellen in kolom B):

sub snb2()
  sn=split(join(filter(application.transpose(columns(2).specialcells(2)),":"),":"),":")
  cells(2,5).resize(ubound(sn)+1)=application.transpose(sn)
end Sub