• Privacywetgeving
    Het is bij Helpmij.nl niet toegestaan om persoonsgegevens in een voorbeeld te plaatsen. Alle voorbeelden die persoonsgegevens bevatten zullen zonder opgaaf van reden verwijderd worden. In de vraag zal specifiek vermeld moeten worden dat het om fictieve namen gaat.

Kolom splitsen en automatisch invullen met waarde uit sommige cellen

Status
Niet open voor verdere reacties.
D

Dataheertje

Gebruiker
Lid geworden
16 jun 2016
Berichten
35
Ik heb een groot databestand met ca 35000 regels.
In de eerste kolom zijn waarden aanwezig die eigenlijk gesplitst hadden moeten zijn over twee kolommen.
Het oorspronkelijke bestand is vrij waardevol (komt niet zo makkelijk een nieuwe voor).
Met 'tekst naar kolommen' kan ik de inhoud niet splitsen.
Is er een mogelijkheid om de eerste kolom te splitsen en automatisch in te vullen (zie bijgaand voorbeeld)
 

Bijlagen

  • helpmij.xlsx
    9,7 KB · Weergaven: 44
Probeer het eens met dit macrootje.
Code: 
Sub Samenvoegen()
Dim broncel As Range, doelcel As Range, i As Integer, j As Integer, k As Integer, z As String
    Set broncel = ActiveSheet.Cells(3, 2)
    Set doelcel = ActiveSheet.Cells(3, 7)
    Do Until broncel.Offset(i, 0) = ""
        If Left(broncel.Offset(i, 0), 1) = "Z" Then
            z = broncel.Offset(i, 0)
        Else
            doelcel.Offset(j, 0) = z
            doelcel.Offset(j, 1) = broncel.Offset(i, 0)
            doelcel.Offset(j, 2) = broncel.Offset(i, 1)
            doelcel.Offset(j, 3) = broncel.Offset(i, 2)
            doelcel.Offset(j, 4) = broncel.Offset(i, 3)
            j = j + 1
            k = 0
        End If
        i = i + 1
    Loop
End Sub

Zal geheid slimmer en sneller kunnen met kortere code :).
 
Niet korter wel sneller.
Code: 
Sub VenA()
  Dim j As Long, x As Long, c00 As String, ar
  With Sheets("helpmij")
    ar = .Range("B3:E" & .Cells(Rows.Count, 2).End(xlUp).Row)
    ReDim ar1(4, 0)
    For j = 1 To UBound(ar)
      If Left(ar(j, 1), 1) = "Z" Then
        c00 = ar(j, 1)
       Else
        ar1(0, x) = c00
        ar1(1, x) = ar(j, 1)
        ar1(2, x) = ar(j, 2)
        ar1(3, x) = ar(j, 3)
        ar1(4, x) = ar(j, 4)
        x = x + 1
        ReDim Preserve ar1(4, x)
      End If
    Next j
    .Cells(1, 15).Resize(x, 5) = Application.Transpose(ar1)
  End With
End Sub
 
Beide dank.
Helaas is het niet gelukt omdat er onregelmatigheden in het bestand blijken te zitten.
Het wachten is nu op een nieuwe lijst.
 
Status
Niet open voor verdere reacties.
Steun Ons

Nieuwste berichten

Terug
Bovenaan Onderaan