• 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.

Celinhoud splitsen, aantal regels extra aanmaken

Status
Niet open voor verdere reacties.
Gert Bouwmeeste

Gert Bouwmeeste

Verenigingslid
Lid geworden
28 nov 2007
Berichten
827
Goedemorgen :)

Ik heb een bestand met 100-den regels. Dat bestand bevat de lidnummers, namen en lessen waar de leden van onze gymvereniging aan deelnemen. Het bestand is een export vanuit de Ledenadministratie (Davilex Online Ledenadministratie) en is niet te beïnvloeden qua lay-out.

Sommige leden nemen aan meer dan één les deel. In de exportfile staan die lessen achter elkaar in één cel, bijvoorbeeld 05 BBB-Gymnastiek51 Total Body Workout27 Zumba. De afzonderlijke lessen worden gescheiden door een ALT+ENTER (= Teken(10).

Wat ik nodig heb is dat als een lid aan meer dan één les deelneemt, dat er dan net zoveel regels gemaakt worden als dat er lessen zijn.

Het tellen van het aantal lessen in een cel (en daarmee het bepalen van het aantal benodigde regels) lukt met een formule. Ik heb ook een UDF voor het splitsen van de celinhoud (met meerdere lessen) in aparte cellen.

Alleen .... het lukt me absoluut niet om het geheel in een macro te krijgen. Die macro zou van boven naar beneden de kolom waar de lessen in staan moeten doorlopen. Bij iedere cel waar de macro dan meer dan één les aantreft moeten dan extra regels daaronder gemaakt worden. Die moeten gevuld worden met hetzelfde lidnummer en dezelfde lidnaam maar met de afzonderlijke lessen.

Ik hoop dat ik het een beetje goed heb uitgelegd. In het voorbeeldbestand heb ik het zo goed mogelijk aangegeven.

Alvast veel dank!
 

Bijlagen

Met de uitkomst in Sheet2
Code: 
Sub VenA()
  Dim j As Long, jj As Long, t As Long, ar, ar1, x1, x2, x3, x4
  ar = Sheets("Helpmij").Cells(1).CurrentRegion
  ReDim ar1(5, 0)
  For j = 2 To UBound(ar)
    x1 = Split(ar(j, 3), vbLf)
    x2 = Split(ar(j, 4), vbLf)
    x3 = Split(ar(j, 5), vbLf)
    x4 = Split(ar(j, 6), vbLf)
    For jj = 0 To UBound(x1)
      ar1(0, t) = ar(j, 1)
      ar1(1, t) = ar(j, 2)
      ar1(2, t) = x1(jj)
      ar1(3, t) = x2(jj)
      ar1(4, t) = x3(jj)
      ar1(5, t) = x4(jj)
      t = t + 1
      ReDim Preserve ar1(5, t)
    Next jj
  Next j
  Sheets("Sheet2").Cells(1).Resize(t, 6) = Application.Transpose(ar1)
End Sub
 
Sjonge .... als ik een pet op had nam ik'm voor je af. Heel diep :thumb:
Dit werkt super en razendsnel.

Nog één vraagje. Ik had een sterk vereenvoudigd voorbeeld gemaakt van de dataset. De kolommen 3, 4 5 en 6 zijn in het werkelijke bestand 33, 34, 35, 36
Als ik je macro overeenkomstig aanpas:
Code: 
x1 = Split(ar(j, [COLOR="#FF0000"][B]33[/B][/COLOR]), vbLf)
x2 = Split(ar(j, [COLOR="#FF0000"][B]34[/B][/COLOR])), vbLf)
x3 = Split(ar(j, [COLOR="#FF0000"][B]35[/B][/COLOR])), vbLf)
x4 = Split(ar(j, [COLOR="#FF0000"][B]36[/B][/COLOR])), vbLf)
Dan gaat het splitsen goed maar komen (uiteraard) de resterende velden niet terug op het blad Sheet2

Hoe moet ik dat aanpassen? Ik sluit een kopie van het originele bestand bij. Had ik ook beter meteen kunnen doen eigenlijk.. sorry ..
 

Bijlagen

is een kwestie van logisch nadenken, de code proberen te begrijpen en een beetje tellen:d
Code: 
Sub VenA()
  Dim j As Long, jj As Long, jjj As Long, t As Long, ar, ar1, x1, x2, x3, x4
  ar = Sheets("Helpmij").Cells(1).CurrentRegion
  ReDim ar1(37, 0)
  For j = 2 To UBound(ar)
    x1 = Split(ar(j, 33), vbLf)
    x2 = Split(ar(j, 34), vbLf)
    x3 = Split(ar(j, 35), vbLf)
    x4 = Split(ar(j, 36), vbLf)
    For jj = 0 To UBound(x1)
      For jjj = 1 To 32
        ar1(jjj - 1, t) = ar(j, jjj)
      Next jjj
      ar1(32, t) = x1(jj)
      ar1(33, t) = x2(jj)
      ar1(34, t) = x3(jj)
      ar1(35, t) = x4(jj)
      ar1(36, t) = ar(j, 37)
      ar1(37, t) = ar(j, 38)
      t = t + 1
      ReDim Preserve ar1(37, t)
    Next jj
  Next j
  Sheets("Sheet2").Cells(1).Resize(t, 38) = Application.Transpose(ar1)
End Sub
 
Dank je wel!

is een kwestie van logisch nadenken, de code proberen te begrijpen en een beetje tellen
Klik om te vergroten...

Daar heb je gelijk in. Alleen van die arrays begrijp ik alleen de theorie een beetje en verder kom ik er niet mee. Helaas. Geen talent voor denk ik.
 
Ik neem aan dat de laatste verandering een getal (numeriek) van de invoer (alfanumeriek maakt? Zal het zo even proberen.

Dat is een goede tip, de site van SNB. Ik heb daar in het verleden veel gebruik van gemaakt. Met name rond mail vanuit Excel versturen.
Heb ik wat te lezen. Tis toch geen weer om wat in de tuin te doen :p
 
VenA,

Het gaat niet helemaal goed met de macro. Alhoewel hij fantastisch werk levert.

a) De datum van de machtiging en de Einddatum van de machtiging komen "verbasterd" over na het draaien van de macro.
b) de laatste 2 kolommen (Begindatum lid en Einddatum lid) worden niet meegenomen. Die twee heb ik overigens later toegevoegd.

Zou je zo vriendelijk willen zijn hier nog even naar te willen kijken?

Alvast erg bedankt!
 

Bijlagen

Probeer het zo maar weer eens
Code: 
Sub SplitsCellen()
  Dim j As Long, jj As Long, jjj As Long, t As Long, ar, ar1, x1, x2, x3, x4
  ar = Sheets("Helpmij").Cells(1).CurrentRegion
  ReDim ar1([COLOR="#FF0000"]39[/COLOR], 0)
  For j = 2 To UBound(ar)
    x1 = Split(ar(j, 33), vbLf)
    x2 = Split(ar(j, 34), vbLf)
    x3 = Split(ar(j, 35), vbLf)
    x4 = Split(ar(j, 36), vbLf)
    For jj = 0 To UBound(x1)
      For jjj = 1 To [COLOR="#FF0000"]30[/COLOR]
        ar1(jjj - 1, t) = ar(j, jjj)
      Next jjj
      [COLOR="#FF0000"]ar1(30, t) = Format(ar(j, 31), "mm-dd-yyyy")
      ar1(31, t) = Format(ar(j, 32), "mm-dd-yyyy")[/COLOR]
      ar1(32, t) = x1(jj)
      ar1(33, t) = x2(jj)
      ar1(34, t) = CDbl(x3(jj))
      ar1(35, t) = CDbl(x4(jj))
      ar1(36, t) = ar(j, 37)
      ar1(37, t) = ar(j, 38)
      [COLOR="#FF0000"]ar1(38, t) = Format(ar(j, 39), "mm-dd-yyyy")
      ar1(39, t) = Format(ar(j, 40), "mm-dd-yyyy")[/COLOR]
      t = t + 1
      ReDim Preserve ar1([COLOR="#FF0000"]39[/COLOR], t)
    Next jj
  Next j
  Sheets("Sheet2").Cells(1).Resize(t, [COLOR="#FF0000"]40[/COLOR]) = Application.Transpose(ar1)
End Sub
 
Super! Dit lijkt heel goed te gaan! Weliswaar is de output in het formaat "m-d-jjjj" maar het wordt in ieder geval goed vertaald!

Zeer bedankt!
 
Status
Niet open voor verdere reacties.
                    Steun ons                    

Nieuwste berichten

Terug
Bovenaan Onderaan